flang 15.0.3
semant.c
Go to the documentation of this file.
1/*
2 * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
3 * See https://llvm.org/LICENSE.txt for license information.
4 * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
5 *
6 */
7
8/**
9 \file
10 \brief This file contains part 1 of the compiler's semantic actions
11 (also known as the semant1 phase).
12*/
13
14#include "gbldefs.h"
15#include "gramsm.h"
16#include "gramtk.h"
17#include "error.h"
18#include "global.h"
19#include "symtab.h"
20#include "symutl.h"
21#include "dtypeutl.h"
22#include "semant.h"
23#include "scan.h"
24#include "dinit.h"
25#include "semstk.h"
26#include "ast.h"
27#include "pragma.h"
28#include "rte.h"
29#include "pd.h"
30#include "interf.h"
31#include "fdirect.h"
32#include "fih.h"
33#include "ccffinfo.h" /* for setfile */
34
35#include "atomic_common.h"
36
37
38static void gen_dinit(int, SST *);
39static void pop_subprogram(void);
40
41static void fix_proc_ptr_dummy_args();
42static void set_len_attributes(SST *, int);
43static void set_char_attributes(int, int *);
44static void set_aclen(SST *, int, int);
45static void copy_type_to_entry(int);
46static void save_host(INTERF *);
47static void restore_host(INTERF *, LOGICAL);
48static void do_end_subprogram(SST *, RU_TYPE);
49static void check_end_subprogram(RU_TYPE, int);
50static const char *name_of_rutype(RU_TYPE);
51static void convert_intrinsics_to_idents(void);
52static int chk_intrinsic(int, LOGICAL, LOGICAL);
53static int create_func_entry(int);
54static int create_func_entry_result(int);
55static int create_var(int);
56static int chk_func_entry_result(int);
57static void get_param_alias_const(SST *, int, int);
58static void set_string_type_from_init(int, ACL *);
59static void fixup_param_vars(SST *, SST *);
60static void save_typedef_init(int, int);
61static void symatterr(int, int, const char *);
62static void fixup_function_return_type(int, int);
63static void get_retval_KIND_value();
64static void get_retval_LEN_value();
65static void get_retval_derived_type();
67
68static int chk_kind_parm(SST *);
69static int get_kind_parm(int, int);
70static int get_kind_parm_strict(int, int);
71static int get_len_parm(int, int);
72static int has_kind_parm_expr(int, int, int);
74static void check_kind_type_param(int dtype);
75static void defer_put_kind_type_param(int, int, char *, int, int, int);
76static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i);
77static int replace_sdsc_in_ast(int sdsc, int ast);
78static void chk_new_param_dt(int, int);
79static int get_vtoff(int, DTYPE);
80#ifdef FLANG_SEMANT_UNUSED
81static int has_length_type_parameter(int);
82#endif
83static int get_highest_param_offset(int);
84static ACL *dup_acl(ACL *src, int sptr);
85static int match_memname(int sptr, int list);
86static LOGICAL is_pdt_dtype(DTYPE dtype);
87static int chk_asz_deferlen(int, int);
88
89static int ident_host_sub = 0;
90static void defer_ident_list(int ident, int proc);
91static void clear_ident_list();
92static void decr_ident_use(int ident, int proc);
93static void check_duplicate(bool checker, const char * op);
94#ifdef GSCOPEP
95static void fixup_ident_bounds(int);
96#endif
97
98static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr);
99static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr,
100 char access);
101static LOGICAL ignore_common_decl(void);
102static void record_func_result(int func_sptr, int func_result_sptr,
103 LOGICAL in_ENTRY);
105static void clear_iface(int i, SPTR iface);
106static bool do_fixup_param_vars_for_derived_arrays(bool, SPTR, int);
107static void gen_unique_func_ast(int ast, SPTR sptr, SST *stkptr);
108
110static int iface_avail;
111static int iface_size;
112
115
116static STSK *stsk; /* gen_dinit() defines, semant1() uses */
124static struct {
125 int kind;
129
130#define _LEN_CONST 1
131#define _LEN_ASSUM 2
132#define _LEN_ZERO 3
133#define _LEN_ADJ 4
134#define _LEN_DEFER 5
135
136/** \brief Subprogram prefix struct defintions for RECURESIVE, PURE,
137 IMPURE, ELEMENTAL, and MODULE.
138 */
139static struct subp_prefix_t {
140 bool recursive; /** processing RECURSIVE attribute */
141 bool pure; /** processing PURE attribute */
142 bool impure; /** processing IMPURE attribute */
143 bool elemental; /** processing ELEMENTAL attribute */
144 bool module; /** processing MODULE attribute */
146
147static void clear_subp_prefix_settings(struct subp_prefix_t *);
148static void check_module_prefix();
149
150static int mscall;
151static int cref;
152static int nomixedstrlen;
153static int next_enum;
154
155/* for non array parameters, default set by attributes of the function
156 */
157#define BYVALDEFAULT(ffunc) \
158 (!(PASSBYREFG(ffunc)) && \
159 (PASSBYVALG(ffunc) | STDCALLG(ffunc) | CFUNCG(ffunc)))
160
161/* flag indicating the presence of a 'host' for contained subprograms. Values
162 * are selected so that they can be used as a mask to determine when an
163 * IMPLICIT NONE statement has already been specified:
164 *
165 * 0x02 - no host present (module or top level subprogram)
166 * 0x04 - host present (within a module CONTAINed subprogram)
167 * 0x08 - host present (within a CONTAINed subprogram in another subprogram)
168 */
169static int host_present;
171static int end_of_host;
172
173#define ERR310(s1, s2) error(310, 3, gbl.lineno, s1, s2)
174/*
175 * Declarations for processing the attributes specified in an entity type
176 * declaration. Note that some of the ET_ manifest constants, as well as
177 * the entity_attr struct, are used in other processing, such as for PROCEDURE
178 * attributes; likewise, there are a few ET_ entries that aren't used
179 * for declarations, but are for PROCEDURE attributes such as PASS/NOPASS.
180 */
181#define ET_ACCESS 0
182#define ET_ALLOCATABLE 1
183#define ET_DIMENSION 2
184#define ET_EXTERNAL 3
185#define ET_INTENT 4
186#define ET_INTRINSIC 5
187#define ET_OPTIONAL 6
188#define ET_PARAMETER 7
189#define ET_POINTER 8
190#define ET_SAVE 9
191#define ET_TARGET 10
192#define ET_AUTOMATIC 11
193#define ET_STATIC 12
194#define ET_BIND 13
195#define ET_VALUE 14
196#define ET_VOLATILE 15
197#define ET_PASS 16
198#define ET_NOPASS 17
199#define ET_DEVICE 18
200#define ET_PINNED 19
201#define ET_SHARED 20
202#define ET_CONSTANT 21
203#define ET_PROTECTED 22
204#define ET_ASYNCHRONOUS 23
205#define ET_TEXTURE 24
206#define ET_KIND 25
207#define ET_LEN 26
208#define ET_CONTIGUOUS 27
209#define ET_MANAGED 28
210#define ET_IMPL_MANAGED 29
211#define ET_MAX 30
212
213/* derive bit mask for each entity type */
214
215#define ET_B(e) (1 << e)
216
217#define SYMI_SPTR(i) aux.symi_base[i].sptr
218#define SYMI_NEXT(i) aux.symi_base[i].next
219
220/*
221 * structure to record which attributes occurred for an entity type
222 * declaration.
223 */
224static LOGICAL in_entity_typdcl; /* TRUE if processing an entity type decl */
225static struct {
226 int exist; /* bit vector indicating which attributes exist */
227 int dimension; /* TY_ARRAY DT record */
228 char access; /* 'u' => access public ; 'v' => access private */
229 char intent; /* bit vector formed from INTENT_... */
230 char bounds[sizeof(sem.bounds)]; /* copy of sem.bounds[...] */
231 char arrdim[sizeof(sem.arrdim)]; /* copy of sem.arrdim */
232 int pass_arg; /* sptr of the ident in PASS ( <ident> ) */
234
235static struct {
236 const char *name;
237 int no; /* bit vector of attributes which do not coexist */
238} et[ET_MAX] = {
239 {"access",
246 {"allocatable",
252 {"dimension",
260 {"external",
262 ET_B(ET_POINTER))},
263 {"intent",
271 {"intrinsic", ~(ET_B(ET_ACCESS))},
272 {"optional",
278 {"parameter",
281 {"pointer",
287 {"save",
294 {"target",
300 {"automatic",
304 {"static",
309 {"bind",
314 {"value",
319 {"volatile",
325 {"pass", ~(0)},
326 {"nopass", ~(0)},
327 {"device",
332 {"pinned",
336 {"shared",
338 ET_B(ET_VOLATILE))},
339 {"constant", ~(ET_B(ET_DIMENSION) | ET_B(ET_INTENT) | ET_B(ET_ACCESS) |
341 {"protected",
347 {"asynchronous",
353 {"texture",
356 {"kind", 0}, /* 'no' field not used, so make it 0 */
357 {"len", 0}, /* 'no' field not used, so make it 0 */
358 {"contiguous", 0}, /* 'no' field not used, so make it 0 */
359 {"managed",
363 {"implicit-managed", 0}, /* 'no' field not used */
365/*
366 * Declarations for processing the attributes specified in a DEC ATTRIBUTES
367 * declaration.
368 */
369#define DA_ALIAS 0
370#define DA_C 1
371#define DA_STDCALL 2
372#define DA_DLLEXPORT 3
373#define DA_DLLIMPORT 4
374#define DA_VALUE 5
375#define DA_REFERENCE 6
376#define DA_DECORATE 7
377#define DA_NOMIXEDSLA 8
378#define DA_MAX 9
379
380/* derive bit mask for each attribute type */
381
382#define DA_B(e) (1 << e)
383
384/*
385 * structure to record which attributes occurred for a DEC ATTRIBUTES
386 * and BIND declaration.
387 */
389 int exist; /* bit vector indicating which attributes exist */
390 int altname; /* sptr to a character constant representing alias */
391};
392
393static struct dec_attr_t dec_attr;
394static struct dec_attr_t bind_attr;
395
396static struct {
397 const char *name;
398 int no; /* bit vector of attributes which do not coexist */
399 /* unlike the et[...].no values, it's easier to explicitly
400 * specify those which do not coexist as opposed to the
401 * negation of those which can coexist.
402 */
403} da[DA_MAX] = {
404 {"alias", 0},
405 {"c", (DA_B(DA_STDCALL))},
406 {"stdcall", (DA_B(DA_C))},
407 {"dllexport", (0)},
408 {"dllimport", (0)},
409 {"value", (DA_B(DA_REFERENCE))},
410 {"reference", (DA_B(DA_VALUE))},
411 {"decorate", 0},
412 {"nomixed_str_len_arg", 0},
414
415static void process_bind(int);
416
417static void defer_iface(int, int, int, int);
418static void do_iface(int);
419static void do_iface_module(void);
420static void _do_iface(int, int);
421static void fix_iface(int);
422static void fix_iface0();
423
424/** \brief Initialize semantic analyzer for new user subprogram unit.
425 */
426void
427semant_init(int noparse)
428{
429 if (!noparse) {
430 if (sem.doif_base == NULL) {
431 sem.doif_size = 12;
433 }
434 sem.doif_depth = 0;
435 DI_ID(0) = -1;
436 DI_NEST(0) = 0;
437 DI_LINENO(0) = 0;
438 if (sem.stsk_base == NULL) {
439 sem.stsk_size = 12;
441 }
442 sem.block_scope = 0;
444 sem.doconcurrent_dtype = DT_NONE;
445 sem.stsk_depth = 0;
447 sem.eqvlist = 0;
448 sem.eqv_avail = 1;
449 if (sem.eqv_size == 0) {
450 sem.eqv_size = 20;
452 }
453 sem.eqv_ss_avail = 1;
454 if (sem.eqv_ss_size == 0) {
455 sem.eqv_ss_size = 50;
457 }
458 EQV_NUMSS(0) = 0;
460 if (sem.non_private_size == 0) {
463 }
464 if (sem.typroc_base == NULL) {
465 sem.typroc_size = 50;
467 }
468 sem.typroc_avail = 0;
469 if (sem.iface_base == NULL) {
470 sem.iface_size = 50;
472 }
473 sem.iface_avail = 0;
475 sem.flabels = 0; /* not NOSYM - a sym's SYMLK is init'd to NOSYM. if
476 * its SYMLK is NOSYM, then it hasn't been added */
477 sem.nml = NOSYM;
478 sem.atemps = 0;
479 sem.itemps = 0;
480 sem.ptemps = 0;
481 sem.savall = flg.save;
482 sem.savloc = FALSE;
483 sem.autoloc = FALSE;
484 sem.psfunc = FALSE;
488 sem.equal_initializer = false;
489 sem.proc_initializer = false;
491 sem.contiguous = XBIT(125, 0x80000); /* xbit is set for -Mcontiguous */
495 }
496
497 flg.sequence = TRUE;
498 flg.hpf = FALSE;
499
500 if (!noparse) {
502 sem.switch_avl = 0;
503 if (switch_base == NULL) {
504 sem.switch_size = 400;
506 }
509 sem.gdtype = -1;
510 lenspec[0].kind = 0;
511 sem.seql.type = 0; /* [NO]SEQUENCE not yet seen */
512 sem.seql.next = NULL; /* sequence list is empty */
513 sem.dtemps = 0;
514 sem.interface = 0;
515 if (sem.interf_base == NULL) {
516 sem.interf_size = 2;
518 }
521 sem.alloc_std = 0;
523 sem.accl.type = 0; /* PUBLIC/PRIVATE statement not yet seen */
524 sem.accl.next = NULL; /* access list is empty */
526 sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE;
527 sem.master.cnt = 0;
528 sem.critical.cnt = 0;
533 sem.mpaccatomic.ast = 0;
538 sem.parallel = 0;
539 sem.task = 0;
540 sem.orph = 0;
541 sem.target = 0;
542 sem.teams = 0;
546 sem.expect_acc_do = 0;
548 sem.seq_acc_do = 0;
549 sem.expect_cuf_do = 0;
551 sem.is_hpf = FALSE;
552 sem.hpfdcl = 0;
553 sem.ssa_area = 0;
557 sem.blksymnum = 0;
559 sem.in_enum = FALSE;
560 sem.type_mode = 0;
563 sem.tbp_arg = 0;
564 sem.tbp_arg_cnt = 0;
566 sem.generic_tbp = 0;
571 sem.param_offset = 0;
575 sem.len_candidate = 0;
579 sem.new_param_dt = 0;
580 sem.extends = 0;
583 sem.save_aconst = 0;
586 sem.use_seen = 0;
589 sem.stats.allocs = 0;
590 sem.stats.nodes = 0;
591 sem.modhost_proc = 0;
592 sem.modhost_entry = 0;
596 sem.parsing_operator = false;
597
598 mscall = 0;
599 cref = 0;
600 nomixedstrlen = 0;
601#if defined(TARGET_WIN)
602 if (WINNT_CALL)
603 mscall = 1;
604 if (WINNT_CREF)
605 cref = 1;
607 nomixedstrlen = 1;
608#endif
609 } else {
610 /*
611 * Needed for handling the 03 allocatable semantics in semutil2.c via
612 * transform which might occur during the IPA recompile.
613 */
616 }
617
618 sem.sc = SC_LOCAL;
619 stb.curr_scope = 0;
620 ast_init(); /* ast.c */
621 init_intrinsic_opr(); /* semgnr.c */
622 import_init(); /* interf.c */
623 if (!noparse) {
624 if (IN_MODULE) {
625 mod_init();
626 host_present = 0x04;
629 } else if (gbl.internal) { /* hasn't been incremented yet */
630 host_present = 0x08;
633 } else {
634 host_present = 0x02;
635 }
636 }
638 use_init(); /* module.c */
639 bblock_init(); /* bblock.c */
640
641 if (!noparse) {
643
644 if (XBIT(49, 0x1040000))
645 /* T3D/T3E or C90 Cray targets */
646 change_predefineds(ST_CRAY, FALSE);
647
648 end_of_host = 0;
649 if (gbl.internal && sem.which_pass)
651 } else {
652 if (gbl.internal)
654 }
655}
656
657/* for each SC_DUMMY parameter that is passed by value,
658 copy it to a local (reference ) of the same name.
659 all lookups will subsequently find this local
660 */
661static void
663{
664 INT dpdsc;
665 INT psptr;
666 INT iarg;
667 INT newsptr;
668 ITEM *itemp; /* Pointers to items */
669 int byval_default = 0;
670 int thesub;
671
672 if (STYPEG(gbl.currsub) == ST_MODULE)
673 return;
674
675 for (thesub = gbl.currsub; thesub > NOSYM; thesub = SYMLKG(thesub)) {
676 dpdsc = DPDSCG(thesub);
677 for (iarg = PARAMCTG(thesub); iarg > 0; dpdsc++, iarg--) {
678 psptr = *(aux.dpdsc_base + dpdsc);
679
680 /* copy all parameters passed by value to local stack.
681 arrays are always passed by reference unless specifically
682 marked by value
683 */
684 /* disable array and struct parameters passed by value */
685 if (((DTY(DTYPEG(psptr))) == TY_ARRAY) ||
686 ((DTY(DTYPEG(psptr))) == TY_STRUCT)) {
687 if (PASSBYVALG(thesub) || PASSBYVALG(psptr))
688 error(84, 3, gbl.lineno, SYMNAME(psptr),
689 "- VALUE derived types and arrays not yet supported");
690 } else
691 byval_default = BYVALDEFAULT(thesub);
692 if (PASSBYVALG(psptr) && OPTARGG(psptr)) {
693 /* an address is passed for optional value arguments as if call by
694 * reference, but the address is of a temp
695 */
696 continue;
697 }
698 if ((byval_default || PASSBYVALG(psptr)) && (!PASSBYREFG(psptr)) &&
699 (DTY(DTYPEG(psptr)) != TY_ARRAY) &&
700 /* don't redo what we've already done */
701 (strncmp(SYMNAME(psptr), "_V_", 3) != 0)) {
702
703 /* declare a new variable _V_<orig_name> which subsumes the
704 * original by value parameter. The original variable becomes
705 * SC_LOCAL and all further user code references will be to this
706 * SC_LOCAL var.
707 * The copy of the by-value _V_<name> parameter to this local
708 * is done at expand time.
709 */
710 newsptr = lookupsymf("_V_%s", SYMNAME(psptr));
711 if (newsptr > NOSYM) {
712 /* already exists */
713 *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
714 return;
715 }
716 newsptr = getsymf("_V_%s", SYMNAME(psptr));
717 dup_sym(newsptr, stb.stg_base + psptr); /* also _V_... is the dummy*/
718 DCLDP(newsptr, TRUE); /* so DCLCHK is quiet */
719 REFP(newsptr, TRUE);
720 SCP(psptr, SC_LOCAL); /* make the original a local*/
721 /* the byval flag on the original arg (psptr) is cleared in semfin */
722 MIDNUMP(newsptr, psptr); /* link from new symbol to original symbol */
723 *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
724 for (itemp = sem.intent_list; itemp != NULL; itemp = itemp->next) {
725 if (psptr == itemp->t.sptr) {
726 itemp->t.sptr = newsptr;
727 break;
728 }
729 }
730 /*
731 * The original symbol may not yet be classified as an object.
732 * Take care of that here for the original symbol; semfin will
733 * take of new symbol.
734 */
735 switch (STYPEG(psptr)) {
736 case ST_UNKNOWN:
737 case ST_IDENT:
738 STYPEP(psptr, ST_VAR);
739 break;
740 default:;
741 }
742 if (sem.which_pass) {
743 /* the back-end will always copy _V_<orig_name> to
744 * <orig_name>; make sure that <orig_name> is referenced.
745 */
746 sym_is_refd(psptr);
747 }
748
749 } /* if pass by val */
750
751 else if (thesub != gbl.currsub && SCG(psptr) == SC_LOCAL) {
752 /* presumably, thesub is an ST_ENTRY and the parameter has
753 * already been processed; make sure to fix the DPDSC entry.
754 */
755 newsptr = lookupsymf("_V_%s", SYMNAME(psptr));
756 if (newsptr) {
757 *(aux.dpdsc_base + dpdsc) = newsptr; /* fix the DPDSC entry */
758 }
759 }
760
761 } /* for all parameters */
762 }
763}
764
765static void
767{
768 if (sem.master.cnt)
769 error(155, 3, sem.master.lineno, "Unterminated MASTER", CNULL);
770 if (sem.critical.cnt)
771 error(155, 3, sem.critical.lineno, "Unterminated CRITICAL", CNULL);
772 sem_err104(sem.doif_depth, DI_LINENO(sem.doif_depth), "unterminated");
773} /* end_subprogram_checks */
774
775static int restored = 0;
776
777/** \brief Semantic actions - part 1.
778 \param rednum reduction number
779 \param top top of stack after reduction
780 */
781void
782semant1(int rednum, SST *top)
783{
784 SPTR sptr, sptr1, sptr2, block_sptr, sptr_temp, lab;
785 int dtype, dtypeset, ss, numss;
786 int stype, stype1, i;
787 int begin, end, count;
788 int opc;
789 int std;
790 INT rhstop, rhsptr;
792 ITEM *itemp, /* Pointers to items */
793 *itemp1;
794 INT conval;
795 int doif;
796 int evp;
797 ADSC *ad;
798 char *np, *np2; /* char ptrs to symbol names area */
799 int name_prefix_char;
800 VAR *ivl; /* Initializer Variable List */
801 ACL *ict, *ict1; /* Initializer Constant Tree */
802 int ast, alias;
803 static int et_type; /* one of ET_...; '<attr>::=' passes up */
804 int et_bitv;
805 LOGICAL no_init; /* init not allowed for entity decl */
806 int func_result; /* sptr of ident in result ( ident ) */
807 ACL *aclp;
808 ACCL *accessp;
809 int gnr;
810 LOGICAL is_array;
811 LOGICAL is_member;
812 INT val[2];
813 int constarraysize; /* set to 1 if array bounds are constant */
814 ISZ_T arraysize; /* the actual array size; check for < 0 */
815 static int da_type; /* one of DA_...; '<msattr>::=' passes up */
816 PHASE_TYPE prevphase;
817 INT id_name;
818 INT result_name;
819 int construct_name;
820 SST *e1;
821 static int proc_interf_sptr; /* <proc interf ::= <id> passed up */
822 /* for deepcopy */
823 int symi;
824
825 switch (rednum) {
826
827 /* ------------------------------------------------------------------ */
828 /*
829 * <SYSTEM GOAL SYMBOL> ::=
830 */
831 case SYSTEM_GOAL_SYMBOL1:
832 break;
833
834 /* ------------------------------------------------------------------ */
835 /*
836 * <stmt> ::= <stbeg> <statement> <stend>
837 */
838 case STMT1:
839 break;
840
841 /* ------------------------------------------------------------------ */
842 /*
843 * <stbeg> ::=
844 */
845 case STBEG1:
846 if (sem.in_enum) {
847 switch (scn.stmtyp) {
848 case TK_ENUMERATOR:
849 case TK_ENDENUM:
850 break;
851 default:
852 error(155, 3, gbl.lineno, "ENUMERATOR statement expected", CNULL);
854 break;
855 }
856 }
858 sem.alloc_std = 0;
860 if (sem.pgphase == PHASE_USE) {
861 switch (scn.stmtyp) {
862 case TK_USE:
863 case TK_INCLUDE:
864 break;
865 default:
869 }
872 }
873 if (sem.deferred_dertype) {
875 }
876 break;
877 }
878 }
879 if (sem.pgphase == 0 && sem.interface && gbl.currsub == 0) {
880 if (scn.stmtyp == TK_USE) {
881 error(155, 3, gbl.lineno, "USE", "is not in a correct position.");
883 }
884 }
887 }
890 }
893 }
894
895 if (!sem.interface && sem.pgphase < PHASE_EXEC &&
897
898 if (!IN_MODULE)
899 do_iface(0);
900 else
902
904 if (sem.which_pass == 1 && restored == 0) {
906 restored = 1;
907 }
908 }
910 sem.expect_dist_do || (sem.expect_cuf_do && XBIT(137, 0x20000))) {
911 int stt;
912 stt = sem.tkntyp;
913 if (stt == TK_NAMED_CONSTRUCT)
914 stt = get_named_stmtyp();
915 if (stt != TK_DO) {
916 const char *p;
917 switch (DI_ID(sem.doif_depth)) {
918 case DI_ACCDO:
919 sem.doif_depth--; /* remove from stack */
920 p = "ACC DO";
921 break;
922 case DI_ACCLOOP:
923 sem.doif_depth--; /* remove from stack */
924 p = "ACC LOOP";
925 break;
926 case DI_ACCREGDO:
927 sem.doif_depth--; /* remove from stack */
928 p = "ACC REGION DO";
929 break;
930 case DI_ACCREGLOOP:
931 sem.doif_depth--; /* remove from stack */
932 p = "ACC REGION LOOP";
933 break;
934 case DI_ACCKERNELSDO:
935 sem.doif_depth--; /* remove from stack */
936 p = "ACC KERNELS DO";
937 break;
939 sem.doif_depth--; /* remove from stack */
940 p = "ACC KERNELS LOOP";
941 break;
942 case DI_ACCPARALLELDO:
943 sem.doif_depth--; /* remove from stack */
944 p = "ACC PARALLEL DO";
945 break;
947 sem.doif_depth--; /* remove from stack */
948 p = "ACC PARALLEL LOOP";
949 break;
950 case DI_ACCSERIALLOOP:
951 sem.doif_depth--; /* remove from stack */
952 p = "ACC SERIAL LOOP";
953 break;
954 case DI_CUFKERNEL:
955 sem.doif_depth--; /* remove from stack */
956 p = "CUDA KERNEL DO";
957 break;
958 case DI_PDO:
960 p = "OMP DO SIMD";
961 else
962 p = "OMP DO";
963 sem.doif_depth--; /* remove PDO from stack */
965 break;
966 case DI_TARGETSIMD:
967 sem.doif_depth--; /* remove from TARGET SIMD stack */
968 p = "OMP TARGET SIMD";
970 break;
971 case DI_SIMD:
972 sem.doif_depth--; /* remove from SIMD stack */
973 p = "OMP SIMD";
975 break;
976
977 case DI_DISTRIBUTE:
978 sem.doif_depth--; /* remove from DISTRIBUTE stack */
979 p = "OMP DISTRIBUTE";
981 break;
982 case DI_TARGPARDO:
983 sem.doif_depth--; /* remove from TARGET PARALLEL DO stack */
984 p = "OMP TARGET PARALLEL DO";
986 break;
987 case DI_DISTPARDO:
988 sem.doif_depth--; /* remove from stack */
989 p = "OMP DISTRIBUTE PARALLEL DO";
991
992 if (scn.stmtyp == TK_MP_ENDTEAMS) {
993 /* distribute parallel do */
994 break;
995 } else if (scn.stmtyp == TK_MP_ENDTARGET) {
996 /* teams distribute parallel do */
998 } else if (DI_ID(sem.doif_depth) == DI_TEAMS) {
999 /* if the previous stack id is DI_TEAMS
1000 * and scn.stmtyp != TK_MP_ENDTEAMS, then
1001 * this is target teams distribute parallel do
1002 * construct: pop teams and target as we manually
1003 * add stack for those.
1004 */
1005 par_pop_scope();
1006 par_pop_scope();
1007 }
1008
1009 break;
1010 case DI_DOACROSS:
1011 p = "DOACROSS";
1012 goto reset_st;
1013 case DI_PARDO:
1015 p = "PARALLEL DO SIMD";
1016 else
1017 p = "PARALLEL DO";
1018 reset_st:
1019 sem.doif_depth--; /* remove from stack */
1020 /* restore symbol table state */
1021 par_pop_scope();
1022 break;
1023 case DI_TASKLOOP:
1024 sem.doif_depth--; /* remove from stack */
1025 p = "OMP TASKLOOP";
1026 par_pop_scope();
1027 break;
1028 default:
1029 p = "???";
1030 break;
1031 }
1032 error(155, 3, gbl.lineno, "DO loop expected after", p);
1036 sem.expect_acc_do = 0;
1038 sem.seq_acc_do = 0;
1039 sem.expect_cuf_do = 0;
1041 }
1042 } else if (sem.collapse_depth) {
1043 int stt;
1044 stt = sem.tkntyp;
1045 if (stt == TK_NAMED_CONSTRUCT)
1046 stt = get_named_stmtyp();
1047 if (stt != TK_DO) {
1048 /*
1049 * The collapse value is larger than the number of loops;
1050 * this needs to be a fatal error since the DOIF stack
1051 * is probably inconsistent wrt matching ENDDOs etc.
1052 */
1053 error(155, 4, gbl.lineno, "DO loop expected after", "COLLAPSE");
1055 }
1056 }
1057 if (sem.close_pdo) {
1059 switch (DI_ID(sem.doif_depth)) {
1060 case DI_PDO:
1061 if (scn.stmtyp != TK_MP_ENDPDO) {
1062 if (A_TYPEG(STD_AST(STD_PREV(0))) != A_MP_BARRIER)
1063 (void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
1064 sem.doif_depth--; /* pop DOIF stack */
1065 }
1066 /* else ENDPDO pops the stack */
1067 break;
1068 case DI_DISTRIBUTE:
1069 if (scn.stmtyp != TK_MP_ENDDISTRIBUTE) {
1070 sem.doif_depth--; /* pop DOIF stack */
1071 }
1072 /* else ENDDISTRIBUTE pops the stack */
1073 break;
1074 case DI_TEAMSDIST:
1075 if (scn.stmtyp != TK_MP_ENDTEAMSDIST) {
1076 sem.doif_depth--; /* pop DOIF stack */
1077 end_teams();
1078 }
1079 /* else ENDTEAMSDIST pops the stack */
1080 break;
1081 case DI_TARGTEAMSDIST:
1082 if (scn.stmtyp != TK_MP_ENDTARGTEAMSDIST) {
1083 sem.doif_depth--; /* pop DOIF stack */
1084 end_teams();
1085 end_target();
1086 }
1087 /* else ENDTEAMSDIST pops the stack */
1088 break;
1089 case DI_TARGPARDO:
1090 if (scn.stmtyp != TK_MP_ENDTARGPARDO) {
1091 (void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
1092 sem.doif_depth--; /* pop DOIF stack */
1093 end_target();
1094 }
1095 /* else ENDTARGPARDO[SIMD] pops the stack */
1096 break;
1097
1098 case DI_TEAMSDISTPARDO:
1099 if (scn.stmtyp != TK_MP_ENDTEAMSDISTPARDO &&
1100 scn.stmtyp != TK_MP_ENDTEAMSDISTPARDOSIMD) {
1101 sem.doif_depth--; /* pop DOIF stack */
1102 end_teams();
1103 }
1104 /* else ENDTEAMSDISTPARDO[SIMD] pops the stack */
1105 break;
1107 if (scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDO &&
1108 scn.stmtyp != TK_MP_ENDTARGTEAMSDISTPARDOSIMD) {
1109 sem.doif_depth--; /* pop DOIF stack */
1110 end_teams();
1111 end_target();
1112 }
1113 /* else ENDTARGTEAMSDISTPARDO[SIMD] pops the stack */
1114 break;
1115 case DI_DISTPARDO:
1116 if (scn.stmtyp != TK_MP_ENDDISTPARDO &&
1117 scn.stmtyp != TK_MP_ENDDISTPARDOSIMD) {
1118 sem.doif_depth--; /* pop DOIF stack */
1119 }
1120 break;
1121 case DI_TARGETSIMD:
1122 if (scn.stmtyp != TK_MP_ENDTARGSIMD) {
1123 sem.doif_depth--; /* pop DOIF stack */
1124 end_target();
1125 }
1126 /* else ENDTARGETSIMD pops the stack */
1127 break;
1128 case DI_SIMD:
1129 if (scn.stmtyp != TK_MP_ENDSIMD) {
1130 sem.doif_depth--; /* pop DOIF stack */
1131 }
1132 /* else ENDSIMD pops the stack */
1133 break;
1134 case DI_DOACROSS:
1135 /* the DOIF stack could have been popped when the
1136 * DO loop was closed, but it's done here with
1137 * the other DO directives. */
1138 sem.doif_depth--; /* pop DOIF stack */
1139 break;
1140 case DI_PARDO:
1141 if (scn.stmtyp != TK_MP_ENDPARDO) {
1142 sem.doif_depth--; /* pop DOIF stack */
1143 /* else ENDPARDO pops the stack */
1144 }
1145 break;
1146 case DI_TASKLOOP:
1147 if (scn.stmtyp != TK_MP_ENDTASKLOOP) {
1148 sem.doif_depth--; /* pop DOIF stack */
1149 /* else ENDTASKLOOP pops the stack */
1150 }
1151 break;
1152 default:
1153 break;
1154 }
1155 }
1156 break;
1157
1158 /* ------------------------------------------------------------------ */
1159 /*
1160 * <stend> ::=
1161 */
1162 case STEND1:
1163 if (sem.pgphase >= PHASE_EXEC) {
1164 if (sem.atomic[0]) {
1165 sem.atomic[0] = sem.atomic[1] = sem.atomic[2] = FALSE;
1166 error(155, 3, gbl.lineno,
1167 "Statement after ATOMIC UPDATE is not an assignment", CNULL);
1168 } else {
1169 sem.atomic[0] = sem.atomic[1];
1170 sem.atomic[1] = FALSE;
1171 }
1172 if (sem.mpaccatomic.pending &&
1174 error(155, 3, gbl.lineno,
1175 "Statement after ATOMIC UPDATE is not an assignment", CNULL);
1176 }
1177 if (sem.mpaccatomic.seen &&
1180 ;
1181 } else {
1185 }
1186 }
1187 }
1188 freearea(0); /* free ITEM list areas */
1189 sem.new_param_dt = 0;
1190 sem.param_offset = 0;
1191 sem.kind_type_param = 0;
1192 sem.len_type_param = 0;
1194 sem.len_candidate = 0;
1195 sem.kind_candidate = 0;
1196 sem.type_param_sptr = 0;
1198 sem.save_aconst = 0;
1199 sem.tbp_arg = 0;
1200 sem.tbp_arg_cnt = 0;
1201 sem.extends = 0;
1202 if (sem.select_type_seen > 1) {
1203 error(155, 3, gbl.lineno,
1204 "Only a CLASS IS, TYPE IS, CLASS DEFAULT, or END SELECT"
1205 " statement may follow a SELECT TYPE statement",
1206 CNULL);
1207 } else if (sem.select_type_seen == 1) {
1209 } else {
1211 }
1212 if (flg.smp && sem.doif_base && sem.doif_depth &&
1215 entity_attr.access = ' '; /* Need to reset entity access */
1216 sem.parsing_operator = false;
1217 sem.equal_initializer = false;
1218 sem.proc_initializer = false;
1221 sem.elp_stack = NULL;
1222 break;
1223
1224 /* ------------------------------------------------------------------ */
1225 /*
1226 * <statement> ::= <prog title> |
1227 */
1228 case STATEMENT1:
1229 prevphase = sem.pgphase;
1230 sem.gdtype = -1;
1231 lenspec[0].kind = 0;
1232 /*if( sem.which_pass == 1 )
1233 restore_internal_subprograms();*/
1234 restored = 0;
1235 goto statement_shared;
1236 /*
1237 * <statement> ::= <nii> <nim> <entry statement> |
1238 */
1239 case STATEMENT2:
1240 prevphase = sem.pgphase;
1241 SST_ASTP(LHS, SST_ASTG(RHS(3)));
1242 goto statement_shared;
1243 /*
1244 * <statement> ::= <declaration> |
1245 */
1246 case STATEMENT3:
1247 sem.class = 0;
1248 prevphase = sem.pgphase;
1249 if (scn.stmtyp == TK_IMPLICIT) {
1251 errsev(70);
1252 else
1254 } else if (scn.stmtyp == TK_DATA || scn.stmtyp == TK_NAMELIST) {
1255 if (sem.pgphase > PHASE_EXEC)
1256 errsev(70);
1257 else if (sem.pgphase < PHASE_SPEC)
1259 } else if (scn.stmtyp == TK_INTERFACE || scn.stmtyp == TK_ABSTRACT) {
1261 prevphase = PHASE_INIT;
1262 } else if (scn.stmtyp == TK_PARAMETER) {
1263 if (sem.pgphase > PHASE_SPEC)
1264 errsev(70);
1265 else if (sem.pgphase < PHASE_IMPLICIT)
1267 } else if (scn.stmtyp == TK_USE) {
1268 if (sem.pgphase > PHASE_USE)
1269 errsev(70);
1270 else if (sem.pgphase < PHASE_USE)
1272 } else if (scn.stmtyp == TK_IMPORT) {
1273 if (sem.pgphase > PHASE_IMPORT)
1274 errsev(70);
1275 else if (sem.pgphase < PHASE_IMPORT)
1277 } else {
1278 if (sem.pgphase > PHASE_SPEC)
1279 errsev(70);
1280/* allow for routine before a use statement */
1281 /* allow for attributes before a use statement */
1282 else if (scn.stmtyp != TK_ATTRIBUTES && scn.stmtyp != TK_MP_DECLARESIMD)
1284 }
1285 sem.gdtype = -1;
1286 lenspec[0].kind = 0;
1287 goto statement_shared;
1288 /*
1289 * <statement> ::= <nii> <nim> <simple stmt> |
1290 */
1291 case STATEMENT4:
1292 prevphase = sem.pgphase;
1293 SST_ASTP(LHS, SST_ASTG(RHS(3)));
1294 goto statement_shared;
1295 /*
1296 * <statement> ::= <nii> <nim> <GOTO stmt> |
1297 */
1298 case STATEMENT5:
1299 prevphase = sem.pgphase;
1300 SST_ASTP(LHS, SST_ASTG(RHS(3)));
1301 goto executable_shared;
1302 /*
1303 * <statement> ::= <nii> <nim> <control stmt> |
1304 */
1305 case STATEMENT6:
1306 prevphase = sem.pgphase;
1307 SST_ASTP(LHS, SST_ASTG(RHS(3)));
1308 goto executable_shared;
1309 /*
1310 * <statement> ::= <nii> <nim> <block stmt> |
1311 */
1312 case STATEMENT7:
1313 prevphase = sem.pgphase;
1314 goto statement_end;
1315 /*
1316 * <statement> ::= <nii> <nim> <format stmt> |
1317 */
1318 case STATEMENT8:
1319 prevphase = sem.pgphase;
1320 if (sem.pgphase == PHASE_INIT)
1322 /*
1323 * Allow semant ccsym vars allocated by get_temp to be re-used for
1324 * the next statement, if necessary:
1325 */
1327 SST_ASTP(LHS, SST_ASTG(RHS(3)));
1328 if (SST_ASTG(LHS)) /* TBD: delete this and next stmt */
1329 (void)add_stmt((int)SST_ASTG(LHS));
1330 goto statement_end;
1331 /*
1332 * <statement> ::= <null stmt> |
1333 */
1334 case STATEMENT9:
1335 prevphase = sem.pgphase;
1336 if (scn.currlab) {
1337 errlabel(18, 3, gbl.lineno, SYMNAME(scn.currlab),
1338 "- must be followed by a keyword or an identifier");
1339 ast = mk_stmt(A_CONTINUE, 0);
1340 SST_ASTP(LHS, ast);
1341 DEFDP(scn.currlab, 1);
1342 goto executable_shared;
1343 }
1344 SST_ASTP(LHS, 0); /* don't change sem.pgphase */
1345 break;
1346 /*
1347 * <statement> ::= <end> <end stmt> |
1348 */
1349 case STATEMENT10:
1350 /*
1351 * Initialize AST field since an A_END is not generated for the end
1352 * of a host subprogram containing internal procedures
1353 */
1354 prevphase = sem.pgphase;
1355 if (!sem.interface && sem.pgphase < PHASE_EXEC) {
1357 if (sem.which_pass == 1 && restored == 0) {
1359 restored = 1;
1360 }
1361 }
1362 SST_ASTP(LHS, 0);
1363 if (sem.interface) {
1364 if ((gnr = sem.interf_base[sem.interface - 1].generic)) {
1365 if (GTYPEG(gnr) && gbl.rutype == RU_SUBR) {
1366 error(155, 3, gbl.lineno, "Generic INTERFACE with the same name as a "
1367 "derived type may only contain functions -",
1368 SYMNAME(gbl.currsub));
1369 GTYPEP(gnr, 0);
1370 }
1371 if (GNCNTG(gnr) == 0)
1372 sem.interf_base[sem.interface - 1].gnr_rutype = gbl.rutype;
1373 else if (sem.interf_base[sem.interface - 1].gnr_rutype &&
1374 sem.interf_base[sem.interface - 1].gnr_rutype != gbl.rutype) {
1375
1376 errWithSrc(155, 3, SST_LINENOG(RHS(2)),
1377 "Generic INTERFACE may not mix functions and subroutines",
1378 CNULL, SST_COLUMNG(RHS(2)), 0, false, CNULL);
1379 }
1380
1381 if (gbl.currsub)
1382 add_overload(gnr, gbl.currsub);
1383 } else if ((gnr = sem.interf_base[sem.interface - 1].operator)) {
1384 if (sem.interf_base[sem.interface - 1].opval == OP_ST) {
1385 if (gbl.rutype != RU_SUBR)
1386 error(155, 3, gbl.lineno,
1387 "Assignment INTERFACE requires subroutines -",
1388 SYMNAME(gbl.currsub));
1389 else if (PARAMCTG(gbl.currsub) != 2)
1390 error(155, 3, gbl.lineno,
1391 "Assignment INTERFACE requires subroutines 2 arguments -",
1392 SYMNAME(gbl.currsub));
1393 } else {
1394 if (gbl.rutype != RU_FUNC)
1395 error(155, 3, gbl.lineno, "Operator INTERFACE requires functions -",
1396 SYMNAME(gbl.currsub));
1397 else if (PARAMCTG(gbl.currsub) != 1 && PARAMCTG(gbl.currsub) != 2)
1398 error(
1399 155, 3, gbl.lineno,
1400 "Operator INTERFACE requires functions with 1 or 2 arguments -",
1401 SYMNAME(gbl.currsub));
1402 }
1403 add_overload(gnr, gbl.currsub);
1404 }
1405 if (gbl.currsub)
1407 break;
1408 }
1409
1410 if (gbl.rutype == RU_BDATA) {
1411 /* error if executable statements in block data: */
1412 if (sem.pgphase > PHASE_SPEC)
1413 errsev(71);
1414 } else if (!end_of_host && SST_IDG(RHS(2))) {
1415 chk_adjarr(); /* any extra code for adjustable arrays */
1417 }
1418 /*
1419 * The END statement may be for a module or subprogram. If a
1420 * subprogram, the end AST is generated and semfin() is called.
1421 * If the end of a module, there are two cases:
1422 * 1. only specifications were seen (i.e., no contained subprograms);
1423 * since the module blockdata will be output, the end AST needs
1424 * to be generated, however, semfin() can't be called.
1425 * 2. module subprograms were present; the module blockdata was
1426 * already written when the CONTAINS was seen; no END ast is
1427 * necessary; semfin() still can't be called.
1428 */
1429 if (gbl.currsub || gbl.rutype == RU_PROG)
1430 SST_ASTP(LHS, mk_stmt(A_END, 0));
1431 if (SST_IDG(RHS(2))) /* end of subprogram */
1433 else
1434 sem.pgphase = PHASE_END_MODULE; /* end of module */
1435 goto statement_shared;
1436 /*
1437 * <statement> ::= <empty file>
1438 */
1439 case STATEMENT11:
1440 prevphase = sem.pgphase;
1441 goto statement_end;
1442 /*
1443 * <statement> ::= INCLUDE <quoted string>
1444 */
1445 case STATEMENT12:
1446 prevphase = sem.pgphase;
1447 sptr = SST_SYMG(RHS(2));
1448 scan_include(stb.n_base + CONVAL1G(sptr));
1449 goto statement_end;
1450 /*
1451 * <statement> ::= <nii> <nim> OPTIONS |
1452 * [stuff that follows OPTIONS is not parsed - hidden by scanner]
1453 */
1454 case STATEMENT13:
1455 prevphase = sem.pgphase;
1456 if (flg.standard)
1457 error(171, 2, gbl.lineno, "OPTIONS", CNULL);
1459 errsev(70);
1460 else {
1461 scan_options();
1463 }
1464 goto statement_end;
1465 /*
1466 * <statement> ::= <nis> <nii> CONTAINS |
1467 */
1468 case STATEMENT14:
1469 prevphase = sem.pgphase;
1470 SST_ASTP(LHS, 0);
1471 /*do_iface(0);*/
1473 if (sem.pgphase >= PHASE_CONTAIN)
1474 errsev(70);
1476 if (gbl.currsub) {
1477 /* internal subprogram context */
1478 if (gbl.rutype == RU_BDATA) {
1479 errsev(70);
1480 goto executable_shared;
1481 }
1482 if (gbl.internal) {
1483 error(155, 3, gbl.lineno, "Internal subprograms may not be nested",
1484 CNULL);
1485 goto executable_shared;
1486 }
1489 gbl.internal = 1;
1490 if (sem.which_pass == 0)
1491 gbl.empty_contains = FALSE;
1493 if (sem.which_pass == 0) {
1494 /*
1495 * when first processing an internal procedure within a module
1496 * subprogram, need to save the state of the host which will be
1497 * restored for subsequent internal procedures within the same
1498 * module subprogram. Note that the scanner ensures that the
1499 * end statement of the internal procedure in this context
1500 * (processing a module the first time) does not terminate
1501 * compilation (scn.end_program_unit is FALSE).
1502 */
1503 save_host_state(0x3);
1505 SST_ASTP(LHS, 0);
1506 } else {
1507 chk_adjarr(); /* any extra code for adjustable arrays */
1509 fix_class_args(gbl.currsub);
1510 save_host_state(0x11);
1511 /*
1512 * When the CONTAINS is seen, ensure that an END ast is
1513 * generated for the host subprogram.
1514 * Note that scan has set 'scn.end_program_unit to TRUE'.
1515 */
1517 int labsym = getsymf(".L%05ld", (long)sem.end_host_labno);
1518 /*
1519 * If a label was present on the end statement of the
1520 * host subprogram, need to define & emit the label now.
1521 */
1522 int lab = declref(labsym, ST_LABEL, 'd');
1523 if (DEFDG(lab))
1524 errlabel(97, 3, 0, SYMNAME(labsym), CNULL);
1525 else
1526 scn.currlab = lab;
1527 L3FP(lab, 1); /* HACK - disable errorcheck in scan.c*/
1528 }
1529 SST_ASTP(LHS, mk_stmt(A_END, 0));
1530 }
1531 sem.end_host_labno = 0;
1532 goto statement_shared;
1533 }
1534 if (IN_MODULE) {
1535 if (ANCESTORG(gbl.currmod) && !HAS_SMP_DECG(ANCESTORG(gbl.currmod)))
1536 error(1210, ERR_Severe, gbl.lineno,
1537 SYMNAME(ANCESTORG(gbl.currmod)), CNULL);
1538 fe_save_state();
1541 /*
1542 * When the CONTAINS is seen, emit a blockdata just in case any
1543 * data statements are seen; ensure that an END ast is generated.
1544 * Note that scan has set 'scn.end_program_unit to TRUE'.
1545 */
1546 SST_ASTP(LHS, mk_stmt(A_END, 0));
1547 goto statement_shared;
1548 }
1549 errsev(70);
1550 goto executable_shared;
1551 /*
1552 * <statement> ::= <directive>
1553 */
1554 case STATEMENT15:
1555 prevphase = sem.pgphase;
1556 if (sem.interface == 0) {
1558 (void)add_stmt(ast);
1559 }
1560 goto statement_end;
1561
1562 executable_shared:
1565 /* fall thru to 'statement_shared' */
1566
1567 statement_shared:
1568
1569 if ((ast = SST_ASTG(LHS))) {
1570 (void)add_stmt(ast);
1571 SST_ASTG(LHS) = 0;
1572 }
1575
1576 if (sem.atomic[2]) {
1577 ast = mk_stmt(A_ENDATOMIC, 0);
1578 (void)add_stmt(ast);
1579 sem.atomic[0] = sem.atomic[2] = FALSE;
1580 }
1581 if (sem.mpaccatomic.apply &&
1583 int ecs;
1585 if (!sem.mpaccatomic.is_acc) {
1587 ecs = mk_stmt(A_MP_ENDATOMIC, 0);
1588 add_stmt(ecs);
1589 } else {
1590 ecs = emit_bcs_ecs(A_MP_ENDCRITICAL);
1591 /* point to each other */
1592 A_LOPP(ecs, sem.mpaccatomic.ast);
1593 A_LOPP(sem.mpaccatomic.ast, ecs);
1594 }
1595 sem.mpaccatomic.ast = 0;
1596 } else {
1597 int ast_atomic;
1598 ast_atomic = mk_stmt(A_ENDATOMIC, 0);
1599 add_stmt(ast_atomic);
1600 A_LOPP(ast_atomic, sem.mpaccatomic.ast);
1601 A_LOPP(sem.mpaccatomic.ast, ast_atomic);
1602 sem.mpaccatomic.ast = 0;
1603 }
1604 }
1605 /*
1606 * If the current statement is labeled and we are inside a DO [WHILE|
1607 * CONCURRENT] loop, search to see if this statement ends the loop.
1608 *
1609 * OpenMP ARB interpretations version 1.0:
1610 * If a do loop nest which shares the same termination statement is
1611 * followed by an ENDDO or ENDPARALLEL, the DO or PARALLEL DO can
1612 * only be specified for the outermost DO.
1613 */
1614 if (scn.currlab != 0 && sem.doif_depth > 0) {
1615 int par_type = 0; /* nonzero => par do needs to be closed */
1616 for (doif = sem.doif_depth; doif > 0; --doif) {
1617 if ((DI_ID(doif) == DI_DO || DI_ID(doif) == DI_DOWHILE ||
1618 DI_ID(doif) == DI_DOCONCURRENT) &&
1619 DI_DO_LABEL(doif) == scn.currlab) {
1620 switch (par_type) {
1621 /*
1622 * If a parallel do appears between two do loops sharing the
1623 * same termination statement, close the parallel do now.
1624 * (The innermost do loop is the parallel do.)
1625 */
1626 case DI_PDO:
1627 case DI_TARGETSIMD:
1628 case DI_SIMD:
1629 case DI_DISTRIBUTE:
1630 case DI_DISTPARDO:
1631 case DI_DOACROSS:
1632 case DI_PARDO:
1633 case DI_TASKLOOP:
1634 case DI_ACCDO:
1635 case DI_ACCLOOP:
1636 case DI_CUFKERNEL:
1638 --sem.doif_depth;
1639 par_type = 0;
1640 }
1641 do_end(DI_DOINFO(doif));
1642 if (sem.which_pass)
1643 direct_loop_end(DI_LINENO(doif), gbl.lineno);
1644 par_type = DI_ID(sem.doif_depth);
1645 }
1646 }
1647 }
1648
1649 /* For END statements clean up end of program unit. */
1650 if (sem.pgphase == PHASE_END) {
1651 if (!end_of_host) {
1652 semfin();
1653 if (IN_MODULE && sem.interface == 0)
1655 if (sem.which_pass != 0 || gbl.internal == 0)
1657 if (sem.which_pass == 0) {
1658 /* CONTAINS clause has an empty body without any internal subprograms */
1659 if (gbl.internal == 1) {
1660 /* even if it CONTAINS no internal routine, still need to change
1661 the entry points of the containing */
1662 if (STYPEG(gbl.currsub) == ST_ENTRY)
1663 STYPEP(gbl.currsub, ST_PROC);
1664
1665 gbl.currsub = 0;
1666 gbl.internal = 0;
1667 gbl.empty_contains = TRUE;
1668 gbl.p_adjarr = NOSYM;
1669 gbl.p_adjstr = NOSYM;
1670 } else if (gbl.internal > 1) {
1671 /*
1672 * we're at the end of an internal procedure within a
1673 * a module during the first pass over the module.
1674 * The scanner does not set scn.end_program_unit to TRUE
1675 * in this context. So now, need to reinitialize for the
1676 * next internal subprogram if it appears.
1677 */
1680 gbl.currsub = 0;
1682 gbl.p_adjarr = NOSYM;
1683 gbl.p_adjstr = NOSYM;
1684 }
1685 }
1686 } else {
1687 if (IN_MODULE && sem.interface == 0) {
1688 gbl.currsub = end_of_host;
1690 gbl.currsub = 0;
1691 }
1693 }
1694 } else if (sem.pgphase == PHASE_END_MODULE) { /* end of module */
1696 /*
1697 * For a module containing just specifications, end_module() calls
1698 * semfin() in which case sem.doif_base is NULL.
1699 * For a module with contained subprograms, semfin() isn't called
1700 * after the last END statement.
1701 */
1703 if (sem.which_pass) {
1704 gbl.currmod = 0;
1705 }
1706 } else if (sem.pgphase == PHASE_CONTAIN && gbl.internal && sem.which_pass) {
1707 /* end of host subprogram*/
1708 semfin();
1709 if (sem.mod_sym && sem.interface == 0)
1711 if (sem.which_pass != 0 || gbl.internal == 0)
1713 }
1714 /*
1715 * Allow semant ccsym vars allocated by get_temp to be re-used for
1716 * the next statement, if necessary:
1717 */
1719 /* fall thru to 'statement_end' */
1720
1721 statement_end: /* Processing for all <statement>s terminates here */
1722 if (STYPEG(gbl.currsub) == ST_ENTRY && FVALG(gbl.currsub) &&
1723 prevphase <= PHASE_USE && sem.pgphase > PHASE_USE) {
1724 int retdtype = DTYPEG(FVALG(gbl.currsub));
1725 int dtsptr = DTY(retdtype + 3);
1726 if (DTY(retdtype) == TY_DERIVED && dtsptr > NOSYM && !DCLDG(dtsptr)) {
1727 fixup_function_return_type(retdtype, dtsptr);
1728 }
1729 }
1730
1731 sem.last_std = STD_PREV(0);
1732 break;
1733
1734 /* ------------------------------------------------------------------ */
1735 /*
1736 * <iii> ::=
1737 */
1738 case III1:
1739 if (sem.interface) {
1740 error(155, 1, gbl.lineno, "Statement is redundant in an INTERFACE block",
1741 CNULL);
1743 }
1744 /* check whether we have entered a program as yet */
1745 if (sem.scope_level == 0) {
1746 dummy_program();
1747 restored = 0;
1748 }
1749 break;
1750
1751 /* ------------------------------------------------------------------ */
1752 /*
1753 * <nii> ::=
1754 */
1755 case NII1:
1756 if (sem.interface) {
1757 errsev(195);
1759 }
1760 /* check whether we have entered a program as yet */
1761 if (sem.scope_level == 0) {
1762 dummy_program();
1763 restored = 0;
1764 }
1765 break;
1766
1767 /* ------------------------------------------------------------------ */
1768 /*
1769 * <nim> ::=
1770 */
1771 case NIM1:
1772 if (IN_MODULE_SPEC) {
1773 ERR310("Illegal statement in the specification part of a MODULE", CNULL);
1775 }
1776 break;
1777
1778 /* ------------------------------------------------------------------ */
1779 /*
1780 * <pgm> ::=
1781 */
1782 case PGM1:
1783 /* check that we have entered a program as yet */
1784 if (sem.scope_level == 0)
1785 dummy_program();
1786 break;
1787
1788 /* ------------------------------------------------------------------ */
1789 /*
1790 * <end> ::=
1791 */
1792 case END1:
1793 if (!sem.interface && sem.pgphase < PHASE_EXEC) {
1794 if (gbl.currsub && !sem.which_pass) {
1795 do_iface(0);
1796 }
1797 if (!IN_MODULE)
1798 do_iface(1);
1799 else
1801 } else if (sem.which_pass && !IN_MODULE && gbl.internal <= 1) {
1802 do_iface(1);
1803 }
1804 break;
1805
1806 /* ------------------------------------------------------------------ */
1807 /*
1808 * <prog title> ::= <routine id> |
1809 */
1810 case PROG_TITLE1:
1811 itemp = ITEM_END;
1812 func_result = 0;
1813 goto prog_title;
1814 /*
1815 * <prog title> ::= <routine id> ( ) <func suffix> |
1816 */
1817 case PROG_TITLE2:
1818 itemp = ITEM_END;
1819 func_result = SST_SYMG(RHS(4));
1820 goto prog_title;
1821 /*
1822 * <prog title> ::= <routine id> ( <formal list> ) <func suffix> |
1823 */
1824 case PROG_TITLE3:
1825 itemp = SST_BEGG(RHS(3));
1826 func_result = SST_SYMG(RHS(5));
1827 prog_title:
1828 /* no parameters allowed for programs */
1829 if (gbl.rutype == RU_PROG && itemp != ITEM_END)
1830 errsev(41);
1831 if (!sem.interface)
1832 gbl.funcline = gbl.lineno;
1833
1834 if (gbl.rutype == RU_FUNC) {
1835 /* reserve one extra space in case this a function requires an
1836 * extra argument - a new argument may be inserted at the
1837 * beginning of the list.
1838 */
1840 aux.dpdsc_size + 100);
1841 *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0;
1842 }
1843
1844 DPDSCP(gbl.currsub, aux.dpdsc_avl);
1846 aux.dpdsc_size + 100);
1847 *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0;
1848 count = 0;
1849 for (; itemp != ITEM_END; itemp = itemp->next) {
1850 sptr = itemp->t.sptr;
1851 if (sptr == 0) { /* alternate return designator (i.e. *) */
1852 if (gbl.rutype != RU_SUBR)
1853 errsev(49);
1854 else if (!sem.interface)
1855 gbl.arets = TRUE;
1856 } else {
1857 if ((sptr < gbl.currsub) && IN_MODULE) {
1858 sptr = insert_sym(sptr);
1859 }
1860 sptr = declsym(sptr, ST_IDENT, TRUE);
1861 if (SCG(sptr) != SC_NONE)
1862 error(42, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1863 SCP(sptr, SC_DUMMY);
1864 if (sem.interface) {
1865 NODESCP(sptr, 1);
1866 IGNOREP(sptr, TRUE);
1867 }
1868 }
1869 count++;
1871 aux.dpdsc_size + 100);
1872 *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr;
1873 }
1874 /* Set parameter count
1875 *
1876 * For procedure pointer symbols it should go into dtype, for old style
1877 * procedure symbols use PARAMCT attribute.
1878 *
1879 * FIXME this might need to go into a function
1880 */
1881 if (is_procedure_ptr(gbl.currsub)) {
1882 set_proc_ptr_param_count_dtype(DTYPEG(gbl.currsub), count);
1883 } else {
1884 PARAMCTP(gbl.currsub, count);
1885 }
1886 SST_ASTP(LHS, 0);
1887
1888 if (IN_MODULE && sem.interface == 0)
1889 gbl.currsub = mod_add_subprogram(gbl.currsub);
1890 record_func_result(gbl.currsub, func_result, FALSE /* not in ENTRY */);
1891 if (bind_attr.exist != -1) {
1892 process_bind(gbl.currsub);
1893 bind_attr.exist = -1;
1894 bind_attr.altname = 0;
1895 }
1896 break;
1897
1898 /*
1899 * <prog title> ::= BLOCKDATA |
1900 */
1901 case PROG_TITLE4:
1902 rhstop = 1;
1903 gbl.rutype = RU_BDATA;
1904 sem.module_procedure = false;
1905 SST_SYMP(RHS(rhstop), getsymbol(".blockdata."));
1906 CCSYMP(SST_SYMG(RHS(rhstop)), 1);
1907 if (IN_MODULE)
1908 ERR310("BLOCKDATA may not appear in a MODULE", CNULL);
1909 goto routine_id;
1910 /*
1911 * <prog title> ::= BLOCKDATA <id> |
1912 */
1913 case PROG_TITLE5:
1914 rhstop = 2;
1915 gbl.rutype = RU_BDATA;
1916 sem.module_procedure = false;
1917 if (IN_MODULE)
1918 ERR310("BLOCKDATA may not appear in a MODULE", CNULL);
1919 goto routine_id;
1920 /*
1921 * <prog title> ::= MODULE <id> |
1922 */
1923 case PROG_TITLE6:
1924 sem.submod_sym = 0;
1926 sptr1 = NOSYM;
1927 goto module_shared;
1928 /*
1929 * <prog title> ::= SUBMODULE ( <id> ) <id> |
1930 */
1931 case PROG_TITLE7:
1932 sem.submod_sym = SST_SYMG(RHS(5));
1934 STYPEP(sem.submod_sym, ST_MODULE);
1935 goto module_shared;
1936 /*
1937 * <prog title> ::= SUBMODULE ( <id> : <id> ) <id> |
1938 */
1939 case PROG_TITLE8:
1940 sem.submod_sym = SST_SYMG(RHS(7));
1942 &sptr1);
1943 goto module_shared;
1944 /*
1945 * <prog title> ::= <module procedure stmt>
1946 */
1947 case PROG_TITLE9:
1948 break;
1949 module_shared:
1950 gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1);
1951 strcpy(gbl.prog_file_name, gbl.curr_file);
1952 if (sem.pgphase != PHASE_INIT) {
1953 errsev(70);
1954 break;
1955 }
1956 if (sem.mod_sym) {
1957 if (sem.mod_cnt == 1)
1958 /* issue error during first pass */
1959 ERR310("MODULEs may not be nested", CNULL);
1960 break;
1961 }
1962 sem.mod_cnt++;
1964 sem.mod_sym = sptr;
1965 setfile(1, SYMNAME(sem.mod_sym), 0);
1966 gbl.currmod = sem.mod_sym;
1969 SST_ASTP(LHS, 0);
1971
1972 /* SUBMODULEs work as if they are hosted within their immediate parents. */
1973 if (sptr1 > NOSYM) {
1974 sem.use_seen = TRUE;
1977 open_module(sptr1);
1979 close_module();
1980 }
1981 break;
1982
1983 /* ------------------------------------------------------------------ */
1984 /*
1985 * <ident> ::= <id>
1986 */
1987 case IDENT1:
1988 sptr = SST_SYMG(RHS(1));
1989 if (STYPEG(sptr) == ST_ALIAS) {
1990 /*SST_SYMP(LHS, SYMLKG(sptr));*/
1991 SST_ALIASP(LHS, 1);
1992 } else
1993 SST_ALIASP(LHS, 0);
1995 break;
1996
1997 /* ------------------------------------------------------------------ */
1998 /*
1999 * <id> ::= <id name>
2000 */
2001 case ID1:
2002 np = scn.id.name + SST_CVALG(RHS(1));
2003 sptr = getsymbol(np);
2004 if (sem.in_dim && sem.type_mode && !KINDG(sptr) &&
2005 STYPEG(sptr) != ST_MEMBER) {
2006 /* possible use of a type parameter in the dimension field
2007 * of an array type component declaration
2008 */
2009 KINDP(sptr, -1);
2010 }
2011 SST_SYMP(LHS, sptr);
2012 SST_ACLP(LHS, 0);
2013 if (sem.arrdim.assumedrank && SCG(sptr) == SC_DUMMY) {
2014 IGNORE_TKRP(sptr, IGNORE_R);
2015 }
2016#ifdef GSCOPEP
2017 if (!sem.which_pass && gbl.internal <= 1 && gbl.currsub) {
2018 ident_host_sub = gbl.currsub;
2019 } else if (!sem.which_pass && gbl.internal > 1 && gbl.currsub
2020 /* && STYPEG(sptr)*/) {
2022 } else if (sem.which_pass && gbl.internal <= 1 &&
2023 internal_proc_has_ident(sptr, gbl.currsub)) {
2024 if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) {
2025 if (FVALG(sptr))
2026 GSCOPEP(FVALG(sptr), 1);
2027 } else if (STYPEG(sptr) == ST_UNKNOWN || STYPEG(sptr) == ST_IDENT ||
2028 ST_ISVAR(STYPEG(sptr))) {
2029 GSCOPEP(sptr, 1);
2030 }
2031 }
2032#endif
2033 break;
2034
2035 /* ------------------------------------------------------------------ */
2036 /*
2037 * <func suffix> ::= |
2038 */
2039 case FUNC_SUFFIX1:
2040 SST_SYMP(LHS, 0);
2041 break;
2042 /*
2043 * <func suffix> ::= BIND <bind attr> <id name> ( <id name> ) |
2044 */
2045 case FUNC_SUFFIX2:
2046 result_name = SST_CVALG(RHS(3));
2047 id_name = SST_CVALG(RHS(5));
2048 goto result_shared;
2049 /*
2050 * <func suffix> ::= BIND <bind attr> |
2051 */
2052 case FUNC_SUFFIX3:
2053
2054 /* pass nothing */
2055 SST_SYMP(LHS, 0);
2056 break;
2057
2058 /*
2059 * <func suffix> ::= <id name> ( <id name> ) BIND <bind attr>
2060 */
2061 case FUNC_SUFFIX4:
2062 /* do nothing */
2063 /* fall through */
2064 /*
2065 * <func suffix> ::= <id name> ( <id name> )
2066 */
2067 case FUNC_SUFFIX5:
2068
2069 result_name = SST_CVALG(RHS(1));
2070 id_name = SST_CVALG(RHS(3));
2071 result_shared:
2072 sptr = 0;
2073 np = scn.id.name + result_name;
2074 if (sem_strcmp(np, "result") == 0) {
2075 np2 = scn.id.name + id_name;
2076 sptr2 = getsymbol(np2);
2077
2078 sptr = chk_intrinsic(sptr2, FALSE, FALSE);
2079 if (scn.stmtyp == TK_ENTRY && gbl.rutype == RU_FUNC) {
2080 /* have a function entry - create its result variable */
2082 } else {
2083 sptr = declsym(sptr, ST_IDENT, TRUE);
2084 SCP(sptr, SC_DUMMY);
2085 }
2086 if (sem.interface) {
2087 NODESCP(sptr, 1);
2088 IGNOREP(sptr, TRUE);
2089 }
2090 } else
2091 error(34, 3, gbl.lineno, np, CNULL);
2092 SST_SYMP(LHS, sptr);
2093 break;
2094
2095 /* ------------------------------------------------------------------ */
2096 /*
2097 * <entry statement> ::= <entry id> |
2098 */
2099 case ENTRY_STATEMENT1:
2100 itemp = ITEM_END;
2101 func_result = 0;
2102 goto entry_statement;
2103 /*
2104 * <entry statement> ::= <entry id> ( ) <func suffix> |
2105 */
2106 case ENTRY_STATEMENT2:
2107 itemp = ITEM_END;
2108 func_result = SST_SYMG(RHS(4));
2109 goto entry_statement;
2110 /*
2111 * <entry statement> ::= <entry id> ( <formal list> ) <func suffix>
2112 */
2113 case ENTRY_STATEMENT3:
2114 itemp = SST_BEGG(RHS(3));
2115 func_result = SST_SYMG(RHS(5));
2116 entry_statement:
2117 if (flg.standard) {
2118 error(535, 2, gbl.lineno, "ENTRY statement", "FORTRAN 2008");
2119 }
2120
2121 entry_seen = TRUE;
2122 sptr2 = SST_SYMG(RHS(1));
2123 if (sptr2 == 0) {
2124 /* an error was detected in <entry id> */
2125 SST_ASTP(LHS, 0);
2126 break;
2127 }
2128
2129 /* write out ENTRY */
2130 sptr1 = getlab();
2131 RFCNTP(sptr1, 1);
2132
2133 /* reserve one extra space in case this is an array-valued function -
2134 * a new argument may be inserted at the beginning of the list.
2135 */
2136 if (gbl.rutype == RU_FUNC) {
2138 aux.dpdsc_size + 100);
2139 *(aux.dpdsc_base + (aux.dpdsc_avl++)) = 0;
2140 } else
2141 DTYPEP(sptr2, 0);
2142 DPDSCP(sptr2, aux.dpdsc_avl);
2144 aux.dpdsc_size + 100);
2145 *(aux.dpdsc_base + (aux.dpdsc_avl)) = 0;
2146 count = 0;
2147 for (; itemp != ITEM_END; itemp = itemp->next) {
2148 sptr = itemp->t.sptr;
2149 if (sptr == 0) { /* alternate return designator (i.e. *) */
2150 if (gbl.rutype != RU_SUBR)
2151 errsev(49);
2152 else
2153 gbl.arets = TRUE;
2154 } else {
2155 sptr = ref_ident(sptr);
2156 stype = STYPEG(sptr);
2157 if (stype == ST_ENTRY) {
2158 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2159 sptr = insert_sym(sptr);
2160 SCP(sptr, SC_DUMMY);
2161 } else if (SCG(sptr) == SC_NONE) {
2162 if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_ARRAY &&
2163 stype != ST_STRUCT && stype != ST_PROC && stype != ST_VAR) {
2164 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2165 }
2166 SCP(sptr, SC_DUMMY);
2167 } else if (SCG(sptr) == SC_LOCAL && !SAVEG(sptr))
2168 /*
2169 * watch out for the case where an <ident> is seen
2170 * as a use in a declaration (e.g., in an adj. array
2171 * expression). NOTE that if it's dinit'd, dinit will
2172 * issue error.
2173 */
2174 SCP(sptr, SC_DUMMY);
2175 else if (SCG(sptr) != SC_DUMMY)
2176 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
2177 }
2179 aux.dpdsc_size + 100);
2180 *(aux.dpdsc_base + (aux.dpdsc_avl++)) = sptr;
2181 count++;
2182 }
2183
2184 PARAMCTP(sptr2, count);
2185 ast = mk_stmt(A_ENTRY, 0);
2186 A_SPTRP(ast, sptr2);
2187 SST_ASTP(LHS, ast);
2188 record_func_result(sptr2, func_result, TRUE /* in ENTRY */);
2189 break;
2190
2191 /* ------------------------------------------------------------------ */
2192 /*
2193 * <routine id> ::= <subr prefix> SUBROUTINE <id> |
2194 */
2195 case ROUTINE_ID1:
2196 rhstop = 3;
2197 gbl.rutype = RU_SUBR;
2198 sem.module_procedure = false;
2199 goto routine_id;
2200 /*
2201 * <routine id> ::= <subr prefix> FUNCTION <id> |
2202 */
2203 case ROUTINE_ID2:
2204 rhstop = 3;
2205 gbl.rutype = RU_FUNC;
2206 sem.module_procedure = false;
2207 /* data type of function not specified */
2208 lenspec[1].len = sem.gdtype = -1;
2209 lenspec[1].propagated = 0;
2210 goto routine_id;
2211 /*
2212 * <routine id> ::= <func prefix> FUNCTION <fcn name> |
2213 */
2214 case ROUTINE_ID3:
2215 rhstop = 3;
2216 gbl.rutype = RU_FUNC;
2218 /*
2219 The KIND was an unresolved ident (e.g., ident from an unprocessed
2220 module),
2221 skip the mod_type until after USE stmt processing
2222 */
2223 sem.gdtype =
2224 mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
2225 lenspec[1].propagated, (int)SST_SYMG(RHS(3)));
2226 }
2227 goto routine_id;
2228 /*
2229 * <routine id> ::= PROGRAM <id>
2230 */
2231 case ROUTINE_ID4:
2232 gbl.rutype = RU_PROG;
2233 sem.module_procedure = false;
2234 rhstop = 2;
2235 if (IN_MODULE)
2236 ERR310("PROGRAM may not appear in a MODULE", CNULL);
2237
2238 routine_id:
2239 is_entry = FALSE;
2240 if (sem.interface && gbl.currsub) {
2241 error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL);
2244 }
2245 if (gbl.empty_contains && sem.pgphase == PHASE_END && sem.which_pass == 0) {
2246 /* empty CONTAINS body with no internal subprograms */
2247 gbl.internal = 0;
2249 }
2250 if (sem.pgphase != PHASE_INIT && !sem.interface) {
2251 if (IN_MODULE && !have_module_state()) {
2252 /* terminate -- ow, reset_module_state() will issue
2253 * an ICE because modstate_file is NULL; could say
2254 * something about CONTAINS, but we currently cannot
2255 * detect the missing CONTAINS of a module after the
2256 * first.
2257 */
2258 error(70, 0, gbl.lineno, CNULL, CNULL);
2259 }
2260 errsev(70);
2261 }
2262 /* C1548: checking MODULE prefix for subprograms that were
2263 declared as separate module procedures */
2264 if (!sem.interface && subp_prefix.module) {
2265 sptr_temp = SST_SYMG(RHS(rhstop));
2266 if (!SEPARATEMPG(sptr_temp) && !find_explicit_interface(sptr_temp))
2267 error(1056, ERR_Severe, gbl.lineno, NULL, NULL);
2268 }
2269
2270 /* First internal subprogram after CONTAINS, semfin may have altered the
2271 * symbol table
2272 * (esp. INVOBJ) for the host subprogram processing. Restore the state to
2273 * what it was
2274 * before semfin. (FS 20415)
2275 */
2276 if (sem.which_pass && sem.pgphase == PHASE_CONTAIN && gbl.internal == 1) {
2278 }
2279
2280 if (!sem.interface && sem.mod_cnt == 0) {
2281 gbl.prog_file_name = (char *)getitem(15, strlen(gbl.curr_file) + 1);
2282 strcpy(gbl.prog_file_name, gbl.curr_file);
2283 }
2284 entry_seen = FALSE;
2285 if (sem.interface) {
2286 /* Open the interface scope. */
2288 /* set curr_scope to parent's scope */
2290 queue_tbp(SST_SYMG(RHS(rhstop)), 0, 0, 0, TBP_IFACE);
2291 }
2292 sptr = block_local_sym(refsym_inscope(SST_SYMG(RHS(rhstop)), OC_OTHER));
2293 if (STYPEG(sptr) == ST_ENTRY
2294 /* Call insert_sym() if there's a type bound
2295 * procedure that is in scope
2296 */
2297 || (STYPEG(sptr) == ST_PROC && CLASSG(sptr) && VTOFFG(sptr))) {
2298 /* this must be the enclosing routine */
2299 sptr = insert_sym(sptr);
2300
2301 } else if (STYPEG(sptr) == ST_PROC && IN_MODULE_SPEC &&
2303 /* separate module procedure is allowed to be declared &
2304 defined within the same module
2305 */
2306 !IS_INTERFACEG(sptr)) {
2307 LOGICAL err = TYPDG(sptr) && SCOPEG(sptr) != stb.curr_scope;
2308 if (!err) {
2309 int dpdsc = 0;
2310 proc_arginfo(sptr, 0, &dpdsc, 0);
2311 err = dpdsc != 0;
2312 }
2313 if (err) {
2314
2315 errWithSrc(155, 3, SST_LINENOG(RHS(rhstop)),
2316 "Redefinition of", SYMNAME(sptr),
2317 SST_COLUMNG(RHS(rhstop)), 0, false, CNULL);
2318 }
2319 }
2321 error(545, 3, gbl.lineno, NULL, NULL);
2322 }
2323 sptr = declsym(sptr, ST_ENTRY, TRUE);
2324
2325 if (sem.interface) {
2326 /* Re-close the interface scope. */
2328 /* curr_scope will be reset by push_scope_level */
2329 }
2330 gbl.currsub = sptr;
2332 if (sem.interface) {
2333 /* For submodules, don't close the scope_stack in order to make
2334 * sure entities defined in parent modules are visible in
2335 * descendant submodules
2336 */
2337 if (!subp_prefix.module)
2338 /* Close the 'normal' scope. */
2340 }
2343 /* Set the storage class; if it's already dummy, then this subprogram
2344 * is an argument for which there is an interface.
2345 */
2346 if (SCG(sptr) != SC_DUMMY) {
2348 SCP(sptr, SC_EXTERN);
2349 else {
2350 SCP(sptr, SC_NONE);
2352 ABSTRACTP(sptr, 1);
2353 INMODULEP(sptr, IN_MODULE);
2354 }
2355 }
2356 }
2357 PUREP(sptr, subp_prefix.pure);
2358 RECURP(sptr, subp_prefix.recursive);
2359 IMPUREP(sptr, subp_prefix.impure);
2360 ELEMENTALP(sptr, subp_prefix.elemental);
2361 if (subp_prefix.module) {
2362 if (!IN_MODULE && !INMODULEG(sptr)) {
2363 ERR310("MODULE prefix allowed only within a module or submodule", CNULL);
2364 } else if (sem.interface) {
2365 /* Use SEPARATEMPP to mark this is submod related subroutines,
2366 * functions, procdures to differentiate regular module. The
2367 * SEPARATEMPP field is overloaded with ISSUBMODULEP field
2368 * ISSUBMODULEP is used for name mangling.
2369 */
2370 SEPARATEMPP(sptr, TRUE);
2371 HAS_SMP_DECP(SCOPEG(sptr), TRUE);
2372 if (IN_MODULE)
2373 INMODULEP(sptr, TRUE);
2374 if (SST_FIRSTG(RHS(rhstop))) {
2375 TBP_BOUND_TO_SMPP(sptr, TRUE);
2376 /* We also set the HAS_TBP_BOUND_TO_SMP flag on the separate module
2377 * procedure's module. This indicates that the module contains a
2378 * separate module procedure declaration to which at least one TBP
2379 * has been bound.
2380 */
2381 HAS_TBP_BOUND_TO_SMPP(SCOPEG(sptr), TRUE);
2382 }
2383 } else {
2384 SEPARATEMPP(sptr, TRUE);
2385
2386 /* check definition vs. declared interface */
2387 /* F2008 [12.6.2.5]
2388 The characteristics and binding label of a procedure are fixed, but the
2389 remainder of the interface may differ in differing contexts, except that
2390 for a separate module procedure body.
2391 */
2392 if (sem.which_pass) {
2394 /* Make sure this def is not from the contains of ancestor module*/
2395 if (def > NOSYM) {
2396 sptr_temp = SYMLKG(sptr) ? SYMLKG(sptr) : sptr;
2397 /* Check Characteristics of procedures matches for definition vs. declaration*/
2398 if (!cmp_interfaces_strict(def, sptr_temp, CMP_IFACE_NAMES |
2400 ;
2401 }
2402 }
2403 }
2404 } else {
2405 if (sem.interface && SYMIG(sptr) && INMODULEG(sptr)) {
2406 for (symi = SYMIG(sptr); symi; symi = SYMI_NEXT(symi)) {
2407 if (STYPEG(SYMI_SPTR(symi)) == ST_OPERATOR ||
2408 STYPEG(SYMI_SPTR(symi)) == ST_USERGENERIC)
2409 error(1212, ERR_Severe, gbl.lineno, SYMNAME(sptr), NULL);
2410 }
2411 }
2412 }
2414 if (gbl.rutype == RU_FUNC) {
2415 /* for a FUNCTION (including ENTRY's), compiler created
2416 * symbols are created to represent the return values and
2417 * are stored in the FVAL field of the ENTRY's.
2418 * In the worst case, each entry will have its own ccsym.
2419 * As references occur (and in semfin), an attempt will be
2420 * made to share the temporaries. Also, at these times,
2421 * the dtype of the temporary will have to be set properly.
2422 * semfin adjusts the storage class if necessary.
2423 */
2424 if (sem.gdtype != -1) {
2425 /* data type of function was specified */
2426 DCLDP(sptr, TRUE);
2427 DTYPEP(sptr, sem.gdtype);
2429 }
2430 } else {
2431 DTYPEP(sptr, 0);
2432 }
2433 SYMLKP(sptr, NOSYM);
2434 FUNCLINEP(sptr, gbl.lineno);
2435 if (gbl.rutype != RU_PROG) {
2436 MSCALLP(sptr, mscall);
2437#ifdef CREFP
2438 CREFP(sptr, cref);
2439 NOMIXEDSTRLENP(sptr, nomixedstrlen);
2440#endif
2441 }
2442 SST_ASTP(LHS, 0);
2443 if (sem.interface) {
2444 init_implicit();
2445 } else if (IN_MODULE) {
2446 } else if (gbl.internal) {
2447 gbl.internal++;
2448 host_present = 0x8;
2449 symutl.none_implicit = sem.none_implicit &= ~host_present;
2450 SCP(sptr, SC_STATIC);
2451 }
2454 if (sem.interface && gbl.internal <= 1) {
2455 /* INTERNAL flag might have gotten set in getsym()
2456 * for this symbol even though it is an interface. An interface
2457 * body should never contain a procedure defined by a subprogram,
2458 * so this flag should never be set for an interface. Because
2459 * getsym() does not have access to sem.interface, we reset the
2460 * INTERNAL flag here.
2461 */
2462 INTERNALP(sptr, 0);
2463 }
2464 IS_INTERFACEP(sptr, sem.interface);
2465 break;
2466
2467 /* ------------------------------------------------------------------ */
2468 /*
2469 * <subr prefix> ::= |
2470 */
2471 case SUBR_PREFIX1:
2472 /* fall through */
2473 /*
2474 * <subr prefix> ::= <prefix spec>
2475 */
2476 case SUBR_PREFIX2:
2478 if (sem.interface) {
2479 /* set curr_scope to parent's scope, so subprogram ID
2480 * gets scope of parent */
2482 }
2483 break;
2484
2485 /* ------------------------------------------------------------------ */
2486 /*
2487 * <prefix spec> ::= <prefix spec> <prefix> |
2488 */
2489 case PREFIX_SPEC1:
2490 break;
2491 /*
2492 * <prefix spec> ::= <prefix>
2493 */
2494 case PREFIX_SPEC2:
2495 break;
2496
2497 /* ------------------------------------------------------------------ */
2498 /*
2499 * <prefix> ::= RECURSIVE |
2500 */
2501 case PREFIX1:
2504 if (subp_prefix.elemental) {
2505 errsev(460);
2506 }
2507 break;
2508 /*
2509 * <prefix> ::= PURE |
2510 */
2511 case PREFIX2:
2514 break;
2515 /*
2516 * <prefix> ::= ELEMENTAL |
2517 */
2518 case PREFIX3:
2521 if (subp_prefix.recursive) {
2522 errsev(460);
2523 }
2524 break;
2525 /*
2526 * <prefix> ::= ATTRIBUTES ( <id name list> )
2527 */
2528 case PREFIX4:
2529 if (!cuda_enabled("attributes"))
2530 break;
2531 break;
2532
2533 /*
2534 * <prefix> ::= IMPURE
2535 */
2536 case PREFIX5:
2539 break;
2540
2541 /*
2542 * <prefix> ::= MODULE
2543 */
2544 case PREFIX6:
2547 break;
2548
2549 /*
2550 * <prefix> ::= LAUNCHBOUNDS ( <launchbound> ) |
2551 */
2552 case PREFIX7:
2553 break;
2554
2555 /*
2556 * <prefix> ::= LAUNCHBOUNDS ( <launchbound> , <launchbound> )
2557 */
2558 case PREFIX8:
2559 break;
2560
2561
2562 /* ------------------------------------------------------------------ */
2563 /*
2564 * <launchbound> ::= <integer>
2565 */
2566 case LAUNCHBOUND1:
2567 break;
2568
2569 /* ------------------------------------------------------------------ */
2570 /*
2571 * <id name list> ::= <id name list> , <id name> |
2572 */
2573 case ID_NAME_LIST1:
2574 rhstop = 3;
2575 goto add_name_to_list;
2576 break;
2577 /*
2578 * <id name list> ::= <id name>
2579 */
2580 case ID_NAME_LIST2:
2581 rhstop = 1;
2582 add_name_to_list:
2583 itemp = (ITEM *)getitem(0, sizeof(ITEM));
2584 itemp->next = ITEM_END;
2585 itemp->t.conval = SST_CVALG(RHS(rhstop));
2586 if (rhstop == 1)
2587 /* adding first item to list */
2588 SST_BEGP(LHS, itemp);
2589 else
2590 /* adding subsequent items to list */
2591 SST_ENDG(RHS(1))->next = itemp;
2592 SST_ENDP(LHS, itemp);
2593 break;
2594
2595 /* ------------------------------------------------------------------ */
2596 /*
2597 * <func prefix> ::= <data type> |
2598 */
2599 case FUNC_PREFIX1:
2600 /* fall through */
2601 /*
2602 * <func prefix> ::= <data type> <prefix spec> |
2603 */
2604 case FUNC_PREFIX2:
2605 /* fall through */
2606 /*
2607 * <func prefix> ::= <prefix spec> <data type>
2608 */
2609 case FUNC_PREFIX3:
2610 /* fall through */
2611 /*
2612 * <func prefix> ::= <prefix spec> <data type> <prefix spec>
2613 */
2614 case FUNC_PREFIX4:
2616 if (sem.interface) {
2617 /* set curr_scope to parent's scope, so subprogram ID
2618 * gets scope of parent */
2620 }
2621 break;
2622
2623 /* ------------------------------------------------------------------ */
2624 /*
2625 * <entry id> ::= ENTRY <id>
2626 */
2627 case ENTRY_ID1:
2628 sptr = SST_SYMG(RHS(2));
2629 if (gbl.internal > 1) {
2630 error(155, 3, gbl.lineno, SYMNAME(sptr),
2631 "- The ENTRY statement is not allowed in an internal procedure");
2632 SST_SYMP(LHS, 0);
2633 break;
2634 }
2635 if (sem.doif_depth > 0) {
2636 /* Inside DO, IF, WHERE block; ignore statement */
2637 errsev(118);
2638 SST_SYMP(LHS, 0);
2639 break;
2640 }
2641 if (INSIDE_STRUCT) {
2642 error(117, 3, gbl.lineno,
2643 STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
2644 SST_SYMP(LHS, 0);
2645 break;
2646 }
2647 if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA || sem.interface) {
2648 errsev(70);
2649 SST_SYMP(LHS, 0);
2650 break;
2651 }
2652 if (gbl.rutype == RU_FUNC)
2653 /* have a function entry; create its ST_ENTRY symbol */
2655 else
2656 sptr = declsym(sptr, ST_ENTRY, TRUE);
2657
2658 if (IN_MODULE && sem.interface == 0)
2660 SST_SYMP(LHS, sptr);
2661
2662 SYMLKP(sptr, SYMLKG(gbl.currsub));
2663 SYMLKP(gbl.currsub, sptr);
2664 FUNCLINEP(sptr, gbl.lineno);
2665 MSCALLP(sptr, mscall);
2666 if (sptr != gbl.currsub) {
2667 CFUNCP(sptr, CFUNCG(gbl.currsub));
2668 }
2669#ifdef CREFP
2670 CREFP(sptr, cref);
2671 NOMIXEDSTRLENP(sptr, nomixedstrlen);
2672#endif
2673 is_entry = TRUE;
2674 PUREP(sptr, PUREG(gbl.currsub));
2675 break;
2676
2677 /* ------------------------------------------------------------------ */
2678 /*
2679 * <fcn name> ::= <id> <opt len spec>
2680 */
2681 case FCN_NAME1:
2682 set_len_attributes(RHS(2), 1);
2683 break;
2684
2685 /* ------------------------------------------------------------------ */
2686 /*
2687 * <formal list> ::= <formal list> , <formal> |
2688 */
2689 case FORMAL_LIST1:
2690 rhstop = 3;
2691 goto add_sym_to_list;
2692 /*
2693 * <formal list> ::= <formal>
2694 */
2695 case FORMAL_LIST2:
2696 rhstop = 1;
2697 goto add_sym_to_list;
2698
2699 /* ------------------------------------------------------------------ */
2700 /*
2701 * <formal> ::= <id> |
2702 */
2703 case FORMAL1:
2704 /* scan sets SST_SYMP with sym pointer */
2706 SST_SYMP(LHS, sptr);
2707 break;
2708 /*
2709 * <formal> ::= *
2710 */
2711 case FORMAL2:
2712 SST_SYMP(LHS, 0);
2713 break;
2714
2715 /* ------------------------------------------------------------------ */
2716 /*
2717 * <ident list> ::= <ident list> , <ident> |
2718 */
2719 case IDENT_LIST1:
2720 rhstop = 3;
2721 goto add_sym_to_list;
2722 /*
2723 * <ident list> ::= <ident>
2724 */
2725 case IDENT_LIST2:
2726 rhstop = 1;
2727 add_sym_to_list:
2728 itemp = (ITEM *)getitem(0, sizeof(ITEM));
2729 itemp->next = ITEM_END;
2730 itemp->t.sptr = SST_SYMG(RHS(rhstop));
2731 itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for <access> rules */
2732 if (rhstop == 1)
2733 /* adding first item to list */
2734 SST_BEGP(LHS, itemp);
2735 else
2736 /* adding subsequent items to list */
2737 SST_ENDG(RHS(1))->next = itemp;
2738 SST_ENDP(LHS, itemp);
2739 break;
2740
2741 /* ------------------------------------------------------------------ */
2742 /*
2743 * <end stmt> ::= <END stmt> |
2744 */
2745 case END_STMT1:
2746 if (gbl.rutype == RU_SUBR || gbl.rutype == RU_FUNC)
2748 if (sem.interface && !gbl.rutype)
2749 error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL);
2750 else if (sem.which_pass)
2751 fix_class_args(gbl.currsub);
2752
2753 dummy_program();
2754 if (IN_MODULE_SPEC && gbl.internal == 0)
2755 goto end_of_module;
2756 if (gbl.currsub == 0 && sem.pgphase == PHASE_INIT && gbl.internal)
2758 else if (gbl.internal > 1) {
2759 if (gbl.rutype == RU_PROG || gbl.rutype == RU_BDATA) {
2760 error(302, 3, gbl.lineno, name_of_rutype(gbl.rutype), CNULL);
2761 gbl.internal = 0;
2762 }
2763 } else {
2764 if (0 && sem.which_pass && !sem.mod_cnt && gbl.internal == 0 &&
2765 !sem.interface) {
2766 fprintf(stderr, "OPROC %s:", gbl.src_file);
2767 fprintf(stderr, "%s\n", SYMNAME(gbl.currsub));
2768 }
2770 }
2771 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2772 if (IN_MODULE && sem.interface == 0)
2775 if (!IN_MODULE && !sem.interface) {
2776 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2778 }
2779 defer_pt_decl(0, 0);
2780 break;
2781 /*
2782 * <end stmt> ::= ENDBLOCKDATA <opt ident> |
2783 */
2784 case END_STMT2:
2785 if (gbl.currsub == 0 || gbl.rutype != RU_BDATA)
2786 error(302, 3, gbl.lineno, "BLOCKDATA", CNULL);
2787 else if (SST_SYMG(RHS(2)) &&
2788 strcmp(SYMNAME(gbl.currsub), SYMNAME(SST_SYMG(RHS(2)))) != 0)
2789 error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2790
2791 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2793 break;
2794 /*
2795 * <end stmt> ::= ENDFUNCTION <opt ident> |
2796 */
2797 case END_STMT3:
2799 submod_proc_endfunc:
2800 fix_iface(gbl.currsub);
2801 if (sem.which_pass && !sem.interface) {
2802 fix_class_args(gbl.currsub);
2803 }
2804 if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
2805 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2806 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2807 }
2808 defer_pt_decl(0, 0);
2809 dummy_program();
2811
2812 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2814 if (sem.interface) {
2815 if (DTYPEG(gbl.currsub) == DT_ASSCHAR) {
2816 error(
2817 155, 3, FUNCLINEG(gbl.currsub),
2818 "FUNCTION may not be declared character*(*) when in an INTERFACE -",
2819 SYMNAME(gbl.currsub));
2820 }
2821 if (IN_MODULE) {
2823 }
2824 }
2825 if (IN_MODULE && sem.interface == 0)
2828 if (!IN_MODULE && !sem.interface)
2832 break;
2833 /*
2834 * <end stmt> ::= ENDMODULE <opt ident> |
2835 */
2836 case END_STMT4:
2838 if (sem.mod_sym == 0) {
2839 error(302, 3, gbl.lineno, "MODULE", CNULL);
2840 gbl.internal = 0;
2841 break;
2842 }
2843 if (sem.interface) {
2844 error(310, 3, gbl.lineno, "Missing ENDINTERFACE statement", CNULL);
2845 sem.interface = 0;
2846 }
2847 if (gbl.currsub) {
2848 error(310, 3, gbl.lineno, "Missing END statement", SYMNAME(gbl.currsub));
2849 }
2850 if (SST_SYMG(RHS(2)) &&
2851 strcmp(SYMNAME(sem.mod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0)
2852 error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2853 end_of_module:
2854 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDMODULE);
2855 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2857 fix_iface0();
2858 end_module();
2859 SST_IDP(LHS, 0); /* mark as end of module */
2860 if (sem.mod_cnt == 1) {
2861 sem.mod_cnt++;
2862 /*fe_restart();*/
2863 } else {
2864 sem.mod_cnt = 0;
2865 sem.mod_sym = 0;
2866 sem.submod_sym = 0;
2867 }
2871 break;
2872 /*
2873 * <end stmt> ::= ENDPROGRAM <opt ident> |
2874 */
2875 case END_STMT5:
2876 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2877 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2878 defer_pt_decl(0, 0);
2879 dummy_program();
2881
2882 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2885 break;
2886 /*
2887 * <end stmt> ::= ENDSUBROUTINE <opt ident> |
2888 */
2889 case END_STMT6:
2891 fix_iface(gbl.currsub);
2892 if (sem.which_pass && !sem.interface) {
2893 fix_class_args(gbl.currsub);
2894 }
2895 if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
2896 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
2897 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
2898 }
2899 defer_pt_decl(0, 0);
2900 dummy_program();
2902
2903 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2905 if (sem.interface && IN_MODULE) {
2907 }
2908 if (IN_MODULE && sem.interface == 0)
2911 if (!IN_MODULE && !sem.interface)
2915 break;
2916 /*
2917 * <end stmt> ::= ENDSUBMODULE <opt ident>
2918 */
2919 case END_STMT7:
2921 if (sem.submod_sym <= NOSYM) {
2922 error(302, 3, gbl.lineno, "SUBMODULE", CNULL);
2923 gbl.internal = 0;
2924 break;
2925 }
2926 if (SST_SYMG(RHS(2)) &&
2927 strcmp(SYMNAME(sem.submod_sym), SYMNAME(SST_SYMG(RHS(2)))) != 0) {
2928 error(309, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(2))), CNULL);
2929 }
2930 goto end_of_module;
2931 /*
2932 * <end stmt> ::= ENDPROCEDURE <opt ident>
2933 */
2934 case END_STMT8:
2935 if (gbl.currsub == 0 || !sem.module_procedure) {
2936 ERR310("unexpected END PROCEDURE", CNULL);
2937 break;
2938 }
2939 if (gbl.rutype == RU_FUNC)
2940 goto submod_proc_endfunc;
2941 /* For sub-module procedure points to a subroutine of another module,
2942 we need to take cares of the dummy arguments and process differently
2943 from the general ENDPROCEDURE.
2944 */
2945 if (gbl.rutype == RU_SUBR) {
2946 dummy_program();
2948 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2950 defer_pt_decl(0, 0);
2952 do_end_subprogram(top, gbl.rutype);
2953 break;
2954 }
2955 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
2958 do_end_subprogram(top, gbl.rutype);
2959 gbl.currsub = 0;
2960 break;
2961
2962 /* ------------------------------------------------------------------ */
2963 /*
2964 * <opt ident> ::= |
2965 */
2966 case OPT_IDENT1:
2967 SST_SYMP(LHS, 0);
2968 break;
2969 /*
2970 * <opt ident> ::= <ident>
2971 */
2972 case OPT_IDENT2:
2973 break;
2974
2975 /* ------------------------------------------------------------------ */
2976 /*
2977 * <block stmt> ::= BLOCK |
2978 * <block stmt> ::= <check construct> : BLOCK
2979 *
2980 * Generate block code with the form:
2981 * continue -- first block std (labeled)
2982 * block prolog -- allocate/init/array_check code
2983 * comment (continue) -- prolog end == body begin boundary marker
2984 * block body -- user code
2985 * block epilog -- finalize/deallocate code
2986 * continue -- last block std (labeled)
2987 *
2988 * Each block has an ST_BLOCK sptr where:
2989 * - STARTLAB(sptr) is the top-of-block label
2990 * - ENDLAB(sptr) is the end-of-block label
2991 *
2992 * For any sptr local to a block, the block entry, end-of-prolog, and exit
2993 * stds that are needed for inserting prolog and epilog code are accessible
2994 * via macros defined in symutl.h:
2995 * - BLOCK_ENTRY_STD(sptr)
2996 * - BLOCK_ENDPROLOG_STD(sptr)
2997 * - BLOCK_EXIT_STD(sptr)
2998 * Prolog code can be inserted at the top of the prolog via BLOCK_ENTRY_STD,
2999 * and at the end of the prolog via BLOCK_ENDPROLOG_STD. Epilog code can
3000 * be inserted at the end of the epilog via BLOCK_EXIT_STD. There is no
3001 * known need to insert code at the top of the epilog, so there is no
3002 * marker std between body and epilog code.
3003 */
3004 case BLOCK_STMT1:
3007 case BLOCK_STMT2:
3008 if (DI_NEST(sem.doif_depth) >= DI_B(DI_FIRST_DIRECTIVE) && !XBIT(59,8))
3009 error(1219, ERR_Severe, gbl.lineno,
3010 "BLOCK construct in the scope of a parallel directive", CNULL);
3014 block_sptr = getccsym('b', sem.blksymnum++, ST_BLOCK);
3015 ENCLFUNCP(block_sptr,
3017 sem.construct_sptr = block_sptr;
3018 if (sem.which_pass) {
3019 lab = scn.currlab ? scn.currlab : getlab();
3020 RFCNTI(lab);
3021 // Setting VOL on this block entry label and the exit label just below
3022 // prohibits the back end from deleting them. This is necessary to
3023 // support parallelization and debugging. However, this can cause the
3024 // back end at -O2 and above to generate dead code during unrolling,
3025 // which causes control flow analysis prior to vectorization to fail.
3026 // Pending a more complete fix for this problem, only set this flag at
3027 // low opt levels (and prohibit parallelization of code containing a
3028 // block).
3029 VOLP(lab, flg.opt < 2 && flg.debug && !XBIT(123, 0x400));
3030 ENCLFUNCP(lab, block_sptr);
3031 std = add_stmt(mk_stmt(A_CONTINUE, 0));
3032 STARTLINEP(block_sptr, gbl.lineno);
3033 STARTLABP(block_sptr, lab);
3034 LABSTDP(lab, std);
3035 STD_LABEL(std) = lab;
3036 std = add_stmt(mk_stmt(A_CONTINUE, 0));
3038 ENTSTDP(block_sptr, std);
3039 }
3040 NEED_DOIF(doif, DI_BLOCK);
3041 DI_NAME(doif) = get_construct_name();
3045 break;
3046
3047 /* ------------------------------------------------------------------ */
3048 /*
3049 * <block stmt> ::= ENDBLOCK <construct name>
3050 */
3051 case BLOCK_STMT3:
3052 doif = sem.doif_depth;
3053 if (sem.doif_depth <= 0) {
3054 error(104, ERR_Severe, gbl.lineno, "- mismatched END BLOCK", CNULL);
3055 break;
3056 }
3058 if (DI_NAME(doif) != construct_name)
3059 err307("BLOCK and ENDBLOCK", DI_NAME(doif), construct_name);
3060 if (sem.which_pass) {
3061 if (scn.currlab)
3062 add_stmt(mk_stmt(A_CONTINUE, 0));
3063 if (DI_EXIT_LABEL(doif)) {
3064 std = add_stmt(mk_stmt(A_CONTINUE, 0));
3065 STD_LABEL(std) = DI_EXIT_LABEL(doif);
3066 }
3067 block_sptr = sem.construct_sptr;
3068 lab = getlab();
3069 RFCNTI(lab);
3070 // See the comment just above about the entry label VOL flag.
3071 VOLP(lab, flg.opt < 2 && flg.debug && !XBIT(123, 0x400));
3072 ENCLFUNCP(lab, block_sptr);
3073 std = add_stmt(mk_stmt(A_CONTINUE, 0));
3074 ENDLINEP(block_sptr, gbl.lineno);
3075 ENDLABP(block_sptr, lab);
3076 LABSTDP(lab, std);
3077 STD_LABEL(std) = lab;
3078 }
3079 --sem.doif_depth;
3081 sem.construct_sptr = ENCLFUNCG(sem.construct_sptr);
3082 if (STYPEG(sem.construct_sptr) != ST_BLOCK)
3083 sem.construct_sptr = 0; // not in a construct
3085 break;
3086
3087 /* ------------------------------------------------------------------ */
3088 /*
3089 * <declaration> ::= <data type> <optional comma> <pgm> <typdcl list> |
3090 */
3091 case DECLARATION1:
3092 if (sem.class && sem.type_mode) {
3093 error(155, 3, gbl.lineno, "CLASS components must be pointer or"
3094 " allocatable",
3095 CNULL);
3096 }
3097 SST_ASTP(LHS, 0);
3098 break;
3099 /*
3100 * <declaration> ::= <dimkeyword> <opt attr> <pgm> <dcl id list> |
3101 */
3102 case DECLARATION2:
3103 SST_ASTP(LHS, 0);
3104 break;
3105 /*
3106 * <declaration> ::= <nis> IMPLICIT <pgm> <implicit type> |
3107 */
3108 case DECLARATION3:
3109 if (sem.block_scope)
3110 error(1218, ERR_Severe, gbl.lineno, "An IMPLICIT", CNULL);
3111 SST_ASTP(LHS, 0);
3112 break;
3113 /*
3114 * <declaration> ::= <nis> COMMON <pgm> <common list> |
3115 */
3116 case DECLARATION4:
3117 if (sem.block_scope)
3118 error(1218, ERR_Severe, gbl.lineno, "A COMMON", CNULL);
3119 SST_ASTP(LHS, 0);
3120 break;
3121 /*
3122 * <declaration> ::= <nis> EXTERNAL <opt attr> <pgm> <ident list> |
3123 */
3124 case DECLARATION5:
3125 for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3126 /* Produce a procedure symbol */
3127 if (POINTERG(itemp->t.sptr)) {
3128 LOGICAL was_declared = DCLDG(itemp->t.sptr);
3129 /* External pointer should come out the same as procedure(T) pointer */
3130 sptr = decl_procedure_sym(itemp->t.sptr, proc_interf_sptr,
3131 (entity_attr.exist | ET_B(ET_POINTER)));
3132 sptr = setup_procedure_sym(itemp->t.sptr, proc_interf_sptr,
3133 (entity_attr.exist | ET_B(ET_POINTER)),
3134 entity_attr.access);
3135 DCLDP(sptr, was_declared);
3136 } else {
3137 /* Use simple approach when we can't argue that this needs to be a
3138 * procedure pointer */
3139 sptr = declsym(itemp->t.sptr, ST_PROC, FALSE);
3140 }
3141
3142 if (!TYPDG(sptr)) {
3143 TYPDP(sptr, 1);
3144 }
3145 if (SCG(sptr) == SC_DUMMY) {
3146 IS_PROC_DUMMYP(sptr, 1);
3147 }
3148 }
3149 SST_ASTP(LHS, 0);
3150 break;
3151 /*
3152 * <declaration> ::= <nis> INTRINSIC <opt attr> <pgm> <ident list> |
3153 */
3154 case DECLARATION6:
3155 for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
3156 sptr = refsym(itemp->t.sptr, OC_OTHER);
3157 stype = STYPEG(sptr);
3158 if (!IS_INTRINSIC(sptr)) {
3159 /* Not an intrinsic. So, try finding it */
3160 sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_PD, 0);
3161 if (!sptr2) {
3162 sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_INTRIN, 0);
3163 if (!sptr2) {
3164 sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_GENERIC, 0);
3165 }
3166 }
3167 if (sptr2) {
3168 sptr = sptr2;
3169 stype = STYPEG(sptr);
3170 sptr2 = insert_sym(sptr);
3171 STYPEP(sptr2, ST_ALIAS);
3172 SYMLKP(sptr2, sptr);
3173 }
3174 }
3175 if (IS_INTRINSIC(stype)) {
3176 EXPSTP(sptr, 1); /* Freeze as an intrinsic */
3177 TYPDP(sptr, 1); /* appeared in INTRINSIC statement */
3178 if (stype == ST_GENERIC) {
3179 sptr2 = select_gsame(sptr);
3180 if (sptr2)
3181 /* no need to
3182 * EXPSTP(sptr2, 1);
3183 * symbol is always begins with a .
3184 */
3185 ;
3186 else if (IN_MODULE) {
3187 /* Predefined symbols such as generics are
3188 * not exported into mod files. A statement such as
3189 * use m, ren => max
3190 * will produce a "not public entity" message unless
3191 * we make a symbol that will be exported.
3192 */
3193 sptr2 = insert_sym(sptr);
3194 STYPEP(sptr2, ST_ALIAS);
3195 SYMLKP(sptr2, sptr);
3196 }
3197 }
3198 } else
3199 error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3200 }
3201 SST_ASTP(LHS, 0);
3202 break;
3203 /*
3204 * <declaration> ::= <iii> <nis> SAVE <opt attr> <save list> |
3205 */
3206 case DECLARATION7:
3207 SST_ASTP(LHS, 0);
3208 break;
3209 /*
3210 * <declaration> ::= <iii> <nis> SAVE |
3211 */
3212 case DECLARATION8:
3213 SST_ASTP(LHS, 0);
3214 if (sem.construct_sptr)
3215 SAVEP(sem.construct_sptr, true);
3216 else
3217 sem.savall = TRUE;
3218 sem.savloc = TRUE;
3219 break;
3220 /*
3221 * <declaration> ::= PARAMETER <pgm> ( <ideqc list> ) |
3222 */
3223 case DECLARATION9:
3225 SST_ASTP(LHS, 0);
3226 if (sem.interface == 0)
3227 end_param();
3228 break;
3229 /*
3230 * <declaration> ::= <nis> EQUIVALENCE <pgm> <equiv groups> |
3231 */
3232 case DECLARATION10:
3233 if (sem.block_scope)
3234 error(1218, ERR_Severe, gbl.lineno, "An EQUIVALENCE", CNULL);
3235 SST_ASTP(LHS, 0);
3236 break;
3237 /*
3238 * <declaration> ::= <iii> <nis> DATA <dinit list> |
3239 */
3240 case DECLARATION11:
3241 SST_ASTP(LHS, 0);
3242 break;
3243 /*
3244 * <declaration> ::= PARAMETER <pgm> <vxeqc list> |
3245 */
3246 case DECLARATION12:
3247 if (flg.standard)
3248 error(171, 2, gbl.lineno, "PARAMETER", CNULL);
3250 SST_ASTP(LHS, 0);
3251 if (sem.interface == 0)
3252 end_param();
3253 break;
3254 /*
3255 * <declaration> ::= <iii> <nis> NAMELIST <namelist groups> |
3256 */
3257 case DECLARATION13:
3258 if (sem.block_scope)
3259 error(1218, ERR_Severe, gbl.lineno, "A NAMELIST", CNULL);
3260 SST_ASTP(LHS, 0);
3261 break;
3262 /*
3263 * <declaration> ::= STRUCTURE <pgm> <struct begin1> <struct begin2> |
3264 */
3265 case DECLARATION14:
3266 if (flg.standard)
3267 error(171, 2, gbl.lineno, "STRUCTURE", CNULL);
3268 if (INSIDE_STRUCT && STSK_ENT(0).type != 's' && STSK_ENT(0).type != 'm') {
3269 error(70, 2, gbl.lineno, "(STRUCTURE ignored)", CNULL);
3270 break;
3271 }
3272 /* Get a structure stack entry */
3273 sem.stsk_depth++;
3275 sem.stsk_depth + 12);
3276 stsk = &STSK_ENT(0);
3277
3279
3280 /* Save structure information in structure stack */
3281 stsk->type = 's';
3282 stsk->mem_access = 0;
3283 stsk->dtype = dtype;
3284 stsk->sptr = SST_RNG2G(RHS(4)); /* sym ptr to field name list */
3285 stsk->last = NOSYM;
3287
3288 /* Handle the field-namelist field */
3289
3290 sptr = stsk->sptr;
3291 if (sptr == NOSYM) {
3292 if (sem.stsk_depth != 1)
3293 error(137, 2, gbl.lineno, CNULL, CNULL);
3294 } else {
3295 if (sem.stsk_depth == 1) {
3296 error(136, 2, gbl.lineno, CNULL, CNULL);
3297 } else {
3298 /* link field-namelist into member list at this level */
3299 stsk = &STSK_ENT(1);
3301 }
3302 }
3303 SST_ASTP(LHS, 0);
3304 break;
3305 /*
3306 * <declaration> ::= ENDSTRUCTURE |
3307 */
3308 case DECLARATION15:
3309 if (flg.standard)
3310 error(171, 2, gbl.lineno, "ENDSTRUCTURE", CNULL);
3311 if (INSIDE_STRUCT) {
3312
3313 /* Check out structure, get its length */
3314 stsk = &STSK_ENT(0);
3315 if (stsk->type != 's') {
3316 errsev(160);
3317 break;
3318 }
3319 dtype = stsk->dtype;
3320 sptr = stsk->sptr;
3322
3323 /* Save initializer constant tree (ict) for this structure */
3324 if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) {
3325 /* This is top structure, fix up top subc ict entry */
3326 ict = GET_ACL(15);
3327 ict->id = AC_VMSSTRUCT;
3328 ict->next = NULL;
3329 ict->subc = stsk->ict_beg;
3330 ict->u1.ast = 0;
3331 ict->repeatc = astb.i1;
3332 ict->sptr = 0;
3333 ict->dtype = dtype;
3334 stsk->ict_beg = ict;
3335 }
3337 if (DTY(dtype + 3))
3338 DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
3339
3340 /* Pop out to parent structure (if any) */
3341 sem.stsk_depth--;
3342 stsk = &STSK_ENT(0);
3343
3344 /* For each member in parent structure (if any), having this
3345 * ict generate a substructure (subc) ict entry. These are then
3346 * linked to the parent's ict.
3347 */
3348 if (INSIDE_STRUCT && DTY(dtype + 5) != 0) {
3349 for (; sptr != NOSYM; sptr = SYMLKG(sptr)) {
3350 ict = GET_ACL(15);
3351 ict->id = AC_VMSSTRUCT;
3352 ict->next = NULL;
3353 if (stsk->ict_end)
3354 stsk->ict_end->next = ict;
3355 else
3356 stsk->ict_beg = ict;
3357 stsk->ict_end = ict;
3358 ict->subc = get_getitem_p(DTY(dtype + 5));
3359 ict->u1.ast = 0;
3360 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
3361 ict->repeatc = AD_NUMELM(AD_PTR(sptr));
3362 else
3363 ict->repeatc = astb.i1;
3364 ict->sptr = sptr;
3365 ict->dtype = dtype;
3366 }
3367 }
3368 } else
3369 error(70, 2, gbl.lineno, "(ENDSTRUCTURE ignored)", CNULL);
3370 SST_ASTP(LHS, 0);
3371 break;
3372 /*
3373 * <declaration> ::= RECORD <pgm> <record list>
3374 */
3375 case DECLARATION16:
3376 if (flg.standard)
3377 error(171, 2, gbl.lineno, "RECORD", CNULL);
3378 break;
3379 /*
3380 * <declaration> ::= UNION
3381 */
3382 case DECLARATION17:
3383 if (flg.standard)
3384 error(171, 2, gbl.lineno, "UNION", CNULL);
3385 if (!INSIDE_STRUCT) {
3386 error(70, 2, gbl.lineno, "(UNION ignored)", CNULL);
3387 break;
3388 }
3389 stsk = &STSK_ENT(0);
3390 if (stsk->type != 's' && stsk->type != 'm') {
3391 error(70, 2, gbl.lineno, "(UNION ignored)", CNULL);
3392 break;
3393 }
3394 dtype = get_type(6, TY_UNION, NOSYM);
3395 name_prefix_char = 'u';
3396 goto union_map;
3397 /*
3398 * <declaration> ::= ENDUNION
3399 */
3400 case DECLARATION18:
3401 if (flg.standard)
3402 error(171, 2, gbl.lineno, "ENDUNION", CNULL);
3403 if (!INSIDE_STRUCT) {
3404 error(70, 2, gbl.lineno, "(ENDUNION ignored)", CNULL);
3405 break;
3406 }
3407 stsk = &STSK_ENT(0);
3408 if (stsk->type != 'u') {
3409 errsev(160);
3410 break;
3411 }
3412 dtype = stsk->dtype;
3413 sptr = stsk->sptr;
3415 STSK_ENT(1).last = stsk->last;
3417 if (stsk->ict_beg != NULL) {
3418 STSK *pstsk = &STSK_ENT(1); /* parent (a struct) of the union */
3419#if DEBUG
3420 assert(pstsk->type == 's', "ENDUNION:union not in struct", sptr, 3);
3421#endif
3422 /*
3423 * create a set node of the union which contains all of the
3424 * initializers for the union's maps. This set node is added
3425 * to the structure stack of the union's parent (a structure).
3426 */
3427 ict = GET_ACL(15);
3428 ict->id = AC_VMSUNION;
3429 ict->next = NULL;
3430 ict->subc = stsk->ict_beg;
3431 ict->u1.ast = 0;
3432 ict->repeatc = astb.i1;
3433 ict->sptr = sptr;
3434 ict->dtype = dtype;
3435 if (pstsk->ict_beg == NULL)
3436 pstsk->ict_beg = ict;
3437 else
3438 pstsk->ict_end->next = ict;
3439 pstsk->ict_end = ict;
3440 }
3441 sem.stsk_depth--;
3442 SST_ASTP(LHS, 0);
3443 break;
3444 /*
3445 * <declaration> ::= MAP
3446 */
3447 case DECLARATION19:
3448 if (flg.standard)
3449 error(171, 2, gbl.lineno, "MAP", CNULL);
3450 if (!INSIDE_STRUCT) {
3451 error(70, 2, gbl.lineno, "(MAP ignored)", CNULL);
3452 break;
3453 }
3454 stsk = &STSK_ENT(0);
3455 if (stsk->type != 'u') {
3456 error(70, 2, gbl.lineno, "(MAP ignored)", CNULL);
3457 break;
3458 }
3459 dtype = get_type(6, TY_STRUCT, NOSYM);
3460 name_prefix_char = 'm';
3461 union_map:
3462 stype = ST_MEMBER;
3463 sptr =
3464 declref(getsymf("%c@%05ld", name_prefix_char, (long)dtype), stype, 'r');
3465#if DEBUG
3466 assert(STYPEG(sptr) == stype,
3467 scn.stmtyp == TK_UNION ? "UNION: bad stype" : "MAP: bad stype", sptr,
3468 3);
3469#endif
3470 CCSYMP(sptr, 1);
3471 SYMLKP(sptr, NOSYM);
3472 DTYPEP(sptr, dtype); /* must be done before link members */
3473 DTY(dtype + 3) = 0; /* no tag */
3474 /* link the union or map (structure) into the current structure */
3476
3477 /* Save union information in structure stack */
3478 sem.stsk_depth++;
3480 sem.stsk_depth + 12);
3481 stsk = &STSK_ENT(0);
3482 stsk->type = scn.stmtyp == TK_UNION ? 'u' : 'm';
3483 stsk->mem_access = 0;
3484 stsk->dtype = dtype;
3485 stsk->sptr = sptr; /* sym ptr union */
3486 stsk->last = STSK_ENT(1).last;
3488 SST_ASTP(LHS, 0);
3489 break;
3490 /*
3491 * <declaration> ::= ENDMAP |
3492 */
3493 case DECLARATION20:
3494 if (flg.standard)
3495 error(171, 2, gbl.lineno, "ENDMAP", CNULL);
3496 if (!INSIDE_STRUCT) {
3497 error(70, 2, gbl.lineno, "(ENDMAP ignored)", CNULL);
3498 break;
3499 }
3500 stsk = &STSK_ENT(0);
3501 if (stsk->type != 'm') {
3502 errsev(160);
3503 break;
3504 }
3505 dtype = stsk->dtype;
3506 sptr = stsk->sptr;
3508 STSK_ENT(1).last = stsk->last;
3510 if (stsk->ict_beg != NULL) {
3511 STSK *pstsk = &STSK_ENT(1); /* parent (a union) of the map */
3512#if DEBUG
3513 assert(pstsk->type == 'u', "ENDMAP: map not in union", sptr, 3);
3514#endif
3515 /*
3516 * add the map's initializer trees to the union's (its parent)
3517 * structure stack.
3518 */
3519 if (pstsk->ict_beg == NULL)
3520 pstsk->ict_beg = stsk->ict_beg;
3521 else
3522 pstsk->ict_end->next = stsk->ict_beg;
3523 pstsk->ict_end = stsk->ict_end;
3524 }
3525 sem.stsk_depth--;
3526 SST_ASTP(LHS, 0);
3527 break;
3528 /*
3529 * <declaration> ::= TYPE <opt type spec> <opt attr> <pgm> <id> <opt
3530 * tpsl> |
3531 */
3532 case DECLARATION21:
3534 np = SYMNAME(sptr);
3535 if (strcmp(np, "integer") == 0 || strcmp(np, "logical") == 0 ||
3536 strcmp(np, "real") == 0 || strcmp(np, "doubleprecision") == 0 ||
3537 strcmp(np, "complex") == 0 || strcmp(np, "character") == 0) {
3538 error(155, 3, gbl.lineno, "A derived type type-name must not be the same "
3539 "as the name of the intrinsic type",
3540 np);
3541 if (IS_INTRINSIC(STYPEG(sptr)))
3542 sptr = insert_sym(sptr);
3543 } else if (RESULTG(sptr)) {
3544 error(155, 3, gbl.lineno, "A derived type type-name conflicts with"
3545 " function result -",
3546 np);
3547 sptr = insert_sym(sptr);
3548 } else
3549 sptr = getocsym(sptr, OC_OTHER, TRUE);
3550 if (STYPEG(sptr) == ST_TYPEDEF && DTY(DTYPEG(sptr) + 2) == 0) {
3551 /* This declaration will fill in an empty TYPEDEF created in
3552 * an implicit statement.
3553 */
3554 dtype = sem.stag_dtype = DTYPEG(sptr);
3555 DTY(sem.stag_dtype + 2) = 1; /* size */
3556 } else {
3557 if (STYPEG(sptr) == ST_USERGENERIC) {
3558 int origSym = sptr;
3559 sptr = insert_sym(sptr);
3560 STYPEP(sptr, ST_TYPEDEF);
3561 GTYPEP(origSym, sptr);
3562 } else {
3563 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
3564 }
3565 dtype = sem.stag_dtype = get_type(6, TY_DERIVED, NOSYM);
3566 DTYPEP(sptr, sem.stag_dtype);
3567 DTY(sem.stag_dtype + 2) = 1; /* size */
3568 DTY(sem.stag_dtype + 3) = sptr;
3569 DTY(sem.stag_dtype + 5) = 0;
3570 }
3571#if defined(PARENTP)
3572 if (SST_CVALG(RHS(2)) & 0x4) {
3573 int sym = SST_LSYMG(RHS(2));
3574 int dtype2 = DTYPEG(sym);
3575 /* type extension */
3576 if (CFUNCG(sym)) {
3577 error(155, 3, gbl.lineno, "Cannot EXTEND BIND(C) derived type",
3578 SYMNAME(sym));
3579 } else if (DTY(dtype2) == TY_DERIVED && SEQG(DTY(dtype2 + 3))) {
3580 error(155, 3, gbl.lineno, "Cannot EXTEND SEQUENCE derived type",
3581 SYMNAME(sym));
3582 } else if (SST_CVALG(RHS(2)) & 0x1) {
3583 error(155, 3, gbl.lineno, "EXTENDS may not be used with BIND(C) "
3584 "derived type",
3585 SYMNAME(sym));
3586 }
3587 PARENTP(sptr, sym);
3588 } else {
3589 /* type extension */
3590 PARENTP(sptr, 0);
3591 }
3592 if (SST_CVALG(RHS(2)) & 0x8) {
3593 /* abstract type */
3594 ABSTRACTP(sptr, 1);
3595 }
3596#endif
3597 if (SST_CVALG(RHS(2)) & 0x1)
3598 /* BIND present? */
3599 CFUNCP(sptr, 1);
3600 if (entity_attr.access == 'v') {
3601 /* we can set the private bit immediately here,
3602 * since it doesn't get overwritten later */
3603 PRIVATEP(sptr, 1);
3604 } else if (entity_attr.access == 'u') {
3605 /* if the default access mode for the module is private,
3606 * the private bit gets overwritten in semfin.do_access()
3607 * We need to remember to reset this to public */
3608 accessp = (ACCL *)getitem(3, sizeof(ACCL));
3609 accessp->sptr = sptr;
3610 accessp->type = entity_attr.access;
3611 accessp->oper = ' ';
3612 accessp->next = sem.accl.next;
3613 sem.accl.next = accessp;
3614 }
3615
3616 if (INSIDE_STRUCT)
3617 error(117, 3, gbl.lineno,
3618 STSK_ENT(0).type == 'd' ? "derived type" : "STRUCTURE", CNULL);
3619
3620 /* Get a structure stack entry */
3621 sem.stsk_depth++;
3623 sem.stsk_depth + 12);
3624 stsk = &STSK_ENT(0);
3625 /* Save structure information in structure stack */
3626 stsk->type = 'd';
3627 stsk->mem_access = 0;
3628 stsk->dtype = dtype;
3629 stsk->sptr = sptr;
3630 stsk->last = NOSYM;
3632 sem.type_mode = 1;
3633 SST_ASTP(LHS, 0);
3634 link_parents(stsk, PARENTG(sptr));
3635 break;
3636 /*
3637 * <declaration> ::= ENDTYPE <opt ident> |
3638 */
3639 case DECLARATION22:
3640 if (INSIDE_STRUCT) {
3641 /* Check out structure, get its length */
3642 stsk = &STSK_ENT(0);
3643 if (stsk->type != 'd') {
3644 errsev(160);
3645 break;
3646 }
3647 dtype = stsk->dtype;
3648 sptr = stsk->sptr;
3650 if (dtype && SST_SYMG(RHS(2)) && DTY(dtype + 3) &&
3651 strcmp(SYMNAME(DTY(dtype + 3)), SYMNAME(SST_SYMG(RHS(2)))) != 0) {
3652 error(155, 3, gbl.lineno, "Name on END TYPE statement does not"
3653 " match name on corresponding TYPE statement",
3654 CNULL);
3655 }
3656 if (PARENTG(DTY(dtype + 1)) && DINITG(DTY(dtype + 1))) {
3657 /* Type extension - make sure we initialize any parent components
3658 * that require initialization.
3659 */
3660 build_typedef_init_tree(DTY(dtype + 1), DDTG(DTYPEG(DTY(dtype + 1))));
3661 }
3662 if (ALLOCFLDG(sptr)) {
3664 }
3667
3668 queue_type_param(0, dtype, 0, 2);
3670 queue_type_param(0, 0, 0, 0);
3671
3674 if (!IN_MODULE)
3675 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_ENDTYPE);
3676 /* Call get_static_type_descriptor() to ensure creation of type
3677 * descriptor at its definition point. This is especially important
3678 * for derived types defined in a subprogram and referenced in a
3679 * contains subprogram.
3680 */
3681 if (gbl.internal <= 1)
3683 if (0 && size_of(dtype) == 0 && DTY(dtype + 1) <= NOSYM) {
3684 int oldsptr, tag;
3685 tag = DTY(DTYPEG(sptr) + 3);
3686 if (!UNLPOLYG(tag)) {
3687 /* Create "empty" typedef. */
3688 oldsptr = sptr;
3690 sptr = insert_sym(sptr);
3691 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
3692 dtype = get_type(6, TY_DERIVED, NOSYM);
3693 DTYPEP(sptr, dtype);
3694 DTY(dtype + 1) = NOSYM;
3695 DTY(dtype + 2) = 0; /* will be filled in */
3696 DTY(dtype + 3) = sptr;
3697 DTY(dtype + 5) = 0;
3698 SDSCP(sptr, SDSCG(oldsptr));
3699 DCLDP(sptr, DCLDG(oldsptr));
3701 }
3702 }
3704 } else
3705 error(70, 2, gbl.lineno, "(END TYPE ignored)", CNULL);
3706 sem.type_mode = 0;
3707 sem.tbp_access_stmt = 0;
3708 entity_attr.access = ' '; /* Reset access spec of types */
3709 SST_ASTP(LHS, 0);
3710 break;
3711 /*
3712 * <declaration> ::= VOLATILE <opt attr> <pgm> <vol list> |
3713 */
3714 case DECLARATION23:
3715 SST_ASTP(LHS, 0);
3716 break;
3717 /*
3718 * <declaration> ::= <nis> POINTER <opt attr> <pgm> <ptr list>
3719 */
3720 case DECLARATION24:
3721 SST_ASTP(LHS, 0);
3722 break;
3723 /*
3724 * <declaration> ::= <nis> ALLOCATABLE <opt attr> <pgm> <alloc id list>
3725 */
3726 case DECLARATION25:
3727 SST_ASTP(LHS, 0);
3728 break;
3729 /*
3730 * <declaration> ::= <data type> <opt attr list> :: <pgm> <entity decl
3731 *list> |
3732 */
3733 case DECLARATION26:
3734 if (entity_attr.exist & ET_B(ET_PARAMETER)) {
3736 if (sem.interface == 0)
3737 end_param();
3738 }
3739 SST_ASTP(LHS, 0);
3741 entity_attr.exist = 0;
3742 entity_attr.access = ' ';
3743 bind_attr.exist = -1;
3744 bind_attr.altname = 0;
3745 break;
3746 /*
3747 * <declaration> ::= <intent> <opt attr> <pgm> <ident list> |
3748 */
3749 case DECLARATION27:
3750 if (sem.block_scope)
3751 error(1218, ERR_Severe, gbl.lineno, "An INTENT", CNULL);
3752 count = 0;
3753 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3754 sptr = refsym(itemp->t.sptr, OC_OTHER);
3755 INTENTP(sptr, entity_attr.intent);
3756 if (sem.interface) {
3757 if (SCG(sptr) != SC_DUMMY)
3758 error(134, 3, gbl.lineno, "- intent specified for nondummy argument",
3759 SYMNAME(sptr));
3760 } else {
3761 /* defer checking of storage class until semfin */
3762 itemp1 = (ITEM *)getitem(3, sizeof(ITEM));
3763 itemp1->next = sem.intent_list;
3764 sem.intent_list = itemp1;
3765 itemp1->t.sptr = sptr;
3766 itemp1->ast = gbl.lineno;
3767 }
3768 if (bind_attr.altname && (++count > 1))
3769 error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
3770 if (bind_attr.exist != -1) {
3772 }
3773 }
3774 bind_attr.exist = -1;
3775 bind_attr.altname = 0;
3776 SST_ASTP(LHS, 0);
3777 break;
3778 /*
3779 * <declaration> ::= <access spec> <opt attr> <pgm> <access list> |
3780 */
3781 case DECLARATION28:
3782 count = 0;
3783 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3784 sptr1 = sptr = itemp->t.sptr;
3785 if (STYPEG(sptr) != ST_OPERATOR && STYPEG(sptr) != ST_USERGENERIC)
3786 sptr = refsym(sptr, OC_OTHER);
3787 if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr))
3788 error(84, 3, gbl.lineno, SYMNAME(sptr),
3789 "- must not be an automatic array");
3790 else {
3791 accessp = (ACCL *)getitem(3, sizeof(ACCL));
3792 accessp->sptr = sptr1;
3793 accessp->type = entity_attr.access;
3794 accessp->next = sem.accl.next;
3795 accessp->oper = ' ';
3796 if (itemp->ast == 1)
3797 accessp->oper = 'o';
3798 sem.accl.next = accessp;
3799 }
3800 if (bind_attr.altname && (++count > 1))
3801 error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname),
3802 "- too many variables bound to name");
3803 if (bind_attr.exist != -1) {
3804 if (!IN_MODULE)
3805 error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
3807 }
3808 }
3809 entity_attr.access = ' ';
3810 bind_attr.exist = -1;
3811 bind_attr.altname = 0;
3812 SST_ASTP(LHS, 0);
3813 break;
3814 /*
3815 * <declaration> ::= OPTIONAL <opt attr> <pgm> <ident list> |
3816 */
3817 case DECLARATION29:
3818 if (sem.block_scope)
3819 error(1218, ERR_Severe, gbl.lineno, "An OPTIONAL", CNULL);
3820 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3821 sptr = refsym(itemp->t.sptr, OC_OTHER);
3822 OPTARGP(sptr, 1);
3823 }
3824 SST_ASTP(LHS, 0);
3825 break;
3826 /*
3827 * <declaration> ::= TARGET <opt attr> <pgm> <target list> |
3828 */
3829 case DECLARATION30:
3830 SST_ASTP(LHS, 0);
3831 break;
3832 /*
3833 * <declaration> ::= <nis> <interface> |
3834 */
3835 case DECLARATION31:
3836 SST_ASTP(LHS, 0);
3837 break;
3838 /*
3839 * <declaration> ::= <nis> <end interface> |
3840 */
3841 case DECLARATION32:
3842 SST_ASTP(LHS, 0);
3843 break;
3844 /*
3845 * <declaration> ::= <nis> <pgm> USE <use>
3846 */
3847 case DECLARATION33:
3848 close_module();
3849 SST_ASTP(LHS, 0);
3850 break;
3851 /*
3852 * <declaration> ::= <access spec> |
3853 */
3854 case DECLARATION34:
3855 if (INSIDE_STRUCT) {
3856 if (STSK_ENT(0).type != 'd') {
3857 error(155, 3, gbl.lineno,
3858 "PUBLIC/PRIVATE may only be used in derived types", "");
3859 break;
3860 }
3861 if (entity_attr.access == 'u') {
3862 ERR310("PUBLIC may not appear in a derived type definition", CNULL);
3863 } else {
3864 stsk = &STSK_ENT(0);
3865 sptr = DTY(stsk->dtype + 3); /* tag sptr */
3866 if (stsk->last != NOSYM) {
3867 if (sem.type_mode == 2 && IN_MODULE_SPEC) {
3868 if (queue_tbp(0, 0, 0, stsk->dtype, TBP_STATUS)) {
3869 error(155, 3, gbl.lineno,
3870 "Incorrect sequence of PRIVATE and type bound "
3871 "procedures in",
3872 SYMNAME(sptr));
3873 }
3874 if (sem.tbp_access_stmt) {
3875 error(155, 3, gbl.lineno,
3876 "Redundant PRIVATE statement in type bound "
3877 "procedure section of",
3878 SYMNAME(sptr));
3879 } else {
3880 sem.tbp_access_stmt = 1;
3881 }
3882 } else if (!PARENTG(stsk->last) || PARENTG(stsk->last) != stsk->last)
3883 /* error - private statement appears after member */
3884 error(155, 3, gbl.lineno, "PRIVATE statement must appear before "
3885 "components of derived type",
3886 SYMNAME(sptr));
3887 } else {
3888 if (sem.type_mode == 2 && IN_MODULE_SPEC) {
3889 if (sem.tbp_access_stmt) {
3890 error(155, 3, gbl.lineno,
3891 "Redundant PRIVATE statement in type bound "
3892 "procedure section of",
3893 SYMNAME(sptr));
3894 } else {
3895 sem.tbp_access_stmt = 1;
3896 }
3897 } else
3898 if (stsk->mem_access) {
3899 error(155, 3, gbl.lineno,
3900 "Redundant PRIVATE statement in derived type", SYMNAME(sptr));
3901 }
3902 /* set PUBLIC/PRIVATE here. link_members() will apply it to
3903 the components of this derived type. */
3904 stsk->mem_access = entity_attr.access;
3905 }
3906 }
3907 } else { /* not INSIDE_STRUCT */
3908 if (sem.accl.type) {
3909 if (sem.accl.type == entity_attr.access)
3910 error(155, 2, gbl.lineno, "Redundant PUBLIC/PRIVATE statement",
3911 CNULL);
3912 else
3913 error(155, 3, gbl.lineno, "Conflicting PUBLIC/PRIVATE statement",
3914 CNULL);
3915 } else
3916 sem.accl.type = entity_attr.access;
3917 }
3918 SST_ASTP(LHS, 0);
3919 break;
3920
3921 /*
3922 * <declaration> ::= <procedure stmt> |
3923 */
3924 case DECLARATION35:
3925 SST_ASTP(LHS, 0);
3926 break;
3927 /*
3928 * <declaration> ::= <mp threadprivate> ( <tp list> ) |
3929 */
3930 case DECLARATION36:
3931 for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
3932 sptr = itemp->t.sptr; /* ST_CMBLK */
3933 if (sptr == 0)
3934 continue;
3935 THREADP(sptr, 1);
3936
3937 if (STYPEG(sptr) != ST_CMBLK && !DCLDG(sptr) && !SAVEG(sptr) &&
3938 !in_save_scope(sptr)) {
3939 error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3940 } else if (STYPEG(sptr) != ST_CMBLK && ALLOCATTRG(sptr)) {
3943 }
3944 }
3945 SST_ASTP(LHS, 0);
3946 break;
3947 /*
3948 * <declaration> ::= <dec declaration>
3949 */
3950 case DECLARATION37:
3951 SST_ASTP(LHS, 0);
3952 break;
3953 /*
3954 * <declaration> ::= <pragma declaration> |
3955 */
3956 case DECLARATION38:
3957 SST_ASTP(LHS, 0);
3958 break;
3959 /*
3960 * <declaration> ::= <nis> AUTOMATIC <opt attr> <pgm> <ident list> |
3961 */
3962 case DECLARATION39:
3963 uf("AUTOMATIC");
3964 break;
3965 /*
3966 * <declaration> ::= <nis> STATIC <opt attr> <pgm> <ident list>
3967 */
3968 case DECLARATION40:
3969 uf("STATIC");
3970 break;
3971 /*
3972 * <declaration> ::= BIND <bind attr> <opt attr> <bind list> |
3973 */
3974 case DECLARATION41: {
3975 int ii;
3976 ii = 1;
3977 count = 0;
3978 /* go through ths bind list and call process_bind for each */
3979 if (bind_attr.exist != -1) {
3980 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
3981 if (bind_attr.altname && (++count > 1))
3982 error(84, 3, gbl.lineno, SYMNAME(bind_attr.altname),
3983 "- too many variables bound to name");
3984 if (!IN_MODULE)
3985 error(84, 2, gbl.lineno, "BIND: allowed only in module", 0);
3986 process_bind(itemp->t.sptr);
3987 }
3988 bind_attr.exist = -1;
3989 bind_attr.altname = 0;
3990 }
3991 }
3992 SST_ASTP(LHS, 0);
3993 break;
3994 /*
3995 * <declaration> ::= <nis> <pgm> <import> <opt import> |
3996 */
3997 case DECLARATION42:
3998 SST_ASTP(LHS, 0);
3999 break;
4000 /*
4001 * <declaration> ::= <nis> <pgm> ENUM , BIND ( <id name> ) |
4002 */
4003 case DECLARATION43:
4004 np = scn.id.name + SST_CVALG(RHS(7));
4005 if (sem_strcmp(np, "c") == 0) {
4006 sem.in_enum = TRUE;
4007 } else
4008 error(4, 3, gbl.lineno, "Illegal BIND -", np);
4009 next_enum = 0;
4010 SST_ASTP(LHS, 0);
4011 break;
4012 /*
4013 * <declaration> ::= <nis> ENUMERATOR <opt attr> <enums> |
4014 */
4015 case DECLARATION44:
4016 SST_ASTP(LHS, 0);
4017 break;
4018 /*
4019 * <declaration> ::= <nis> ENDENUM |
4020 */
4021 case DECLARATION45:
4022 sem.in_enum = FALSE;
4023 SST_ASTP(LHS, 0);
4024 break;
4025 /*
4026 * <declaration> ::= <procedure declaration> |
4027 */
4028 case DECLARATION46:
4029 SST_ASTP(LHS, 0);
4030 break;
4031 /*
4032 * <declaration> ::= <type bound procedure> |
4033 */
4034 case DECLARATION47:
4035 SST_ASTP(LHS, 0);
4036 break;
4037 /*
4038 * <declaration> ::= ATTRIBUTES ( <id name list> ) <opt attr> <pgm> <ident
4039 *list> |
4040 */
4041 case DECLARATION48:
4042 if (!cuda_enabled("attributes")) {
4043 SST_ASTP(LHS, 0);
4044 break;
4045 }
4046 SST_ASTP(LHS, 0);
4047 break;
4048 /*
4049 * <declaration> ::= TCONTAINS |
4050 */
4051 case DECLARATION49:
4052 dtype = stsk->dtype;
4053 if (DTY(dtype) == TY_DERIVED) {
4054 int tag = DTY(dtype + 3);
4055 if (SEQG(tag)) {
4056 error(155, 3, gbl.lineno, "Type bound procedure part not allowed "
4057 "for SEQUENCE type",
4058 SYMNAME(tag));
4059 }
4060 if (CFUNCG(tag)) {
4061 error(155, 3, gbl.lineno, "Type bound procedure part not allowed "
4062 "for BIND(C) type",
4063 SYMNAME(tag));
4064 }
4065 }
4066 sem.type_mode = 2;
4067 SST_ASTP(LHS, 0);
4068 break;
4069 /*
4070 * <declaration> ::= <nis> PROTECTED <opt attr> <pgm> <ident list>
4071 */
4072 case DECLARATION50:
4073 if (!IN_MODULE_SPEC) {
4074 error(155, 3, gbl.lineno,
4075 "PROTECTED may only appear in the specification part of a MODULE",
4076 CNULL);
4077 }
4078 for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
4079 sptr = ref_ident_inscope(itemp->t.sptr);
4080 PROTECTEDP(sptr, 1);
4081 }
4082 SST_ASTP(LHS, 0);
4083 break;
4084 /*
4085 * <declaration> ::= <nis> ASYNCHRONOUS <opt attr> <pgm> <ident list>
4086 */
4087 case DECLARATION51:
4088 for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
4089 sptr = ref_ident_inscope(itemp->t.sptr);
4091 !ASYNCG(sptr))
4092 error(1219, ERR_Severe, gbl.lineno,
4093 "ASYNCHRONOUS statement in a BLOCK construct", CNULL);
4094 ASYNCP(sptr, true);
4095 }
4096 SST_ASTP(LHS, 0);
4097 break;
4098
4099 /*
4100 * <declaration> ::= <nis> <accel decl begin> ACCDECL <accel decl list>
4101 */
4102 case DECLARATION52:
4103 SST_ASTP(LHS, 0);
4104 break;
4105 /*
4106 * <declaration> ::= <nis> <accel decl begin> DECLARE <accel decl list> |
4107 */
4108 case DECLARATION53:
4109 SST_ASTP(LHS, 0);
4110 break;
4111 /*
4112 * <declaration> ::= <generic type procedure> |
4113 */
4114 case DECLARATION54:
4115 break;
4116 /*
4117 * <declaration> ::= <final subroutines> |
4118 */
4119 case DECLARATION55:
4120 break;
4121 /*
4122 * <declaration> ::= <nis> CONTIGUOUS <opt attr> <pgm> <ident list>
4123 */
4124 case DECLARATION56:
4125 break;
4126 /*
4127 * <declaration> ::= <nis> <accel decl begin> ROUTINE <accel routine list>
4128 */
4129 case DECLARATION57:
4130 SST_ASTP(LHS, 0);
4131 break;
4132 /*
4133 * <declaration> ::= <nis> <accel decl begin> ROUTINE
4134 * ( <routine id list> ) <accel routine list> |
4135 */
4136 case DECLARATION58:
4137 SST_ASTP(LHS, 0);
4138 break;
4139 /*
4140 * <declaration> ::= <seq> <pgm> |
4141 */
4142 case DECLARATION59:
4143 if (INSIDE_STRUCT && STSK_ENT(0).type == 'd' && SST_CVALG(RHS(1)) == 's') {
4144 stsk = &STSK_ENT(0);
4145 sptr = DTY(stsk->dtype + 3); /* tag sptr */
4146 if (stsk->last != NOSYM) {
4147 /* error - SEQUENCE statement appears after member */
4148 error(
4149 155, 3, gbl.lineno,
4150 "SEQUENCE statement must appear before components of derived type",
4151 SYMNAME(sptr));
4152 } else {
4153 if (SEQG(sptr)) {
4154 error(155, 3, gbl.lineno,
4155 "Redundant SEQUENCE statement in derived type", SYMNAME(sptr));
4156 }
4157 SEQP(sptr, 1); /* set SEQ on the tag of derived type */
4158 if (PARENTG(sptr)) {
4159 error(155, 3, gbl.lineno,
4160 "SEQUENCE may not appear in a derived type with "
4161 "EXTENDS keyword",
4162 CNULL);
4163 }
4164 }
4165 }
4166 SST_ASTP(LHS, 0);
4167 break;
4168 /*
4169 * <declaration> ::= <nis> <mp decl begin> <mp decl> |
4170 */
4171 case DECLARATION60:
4172 break;
4173 /*
4174 * <declaration> ::= <nis> VALUE <opt attr> <pgm> <ident list>
4175 */
4176 case DECLARATION61:
4177 if (sem.block_scope)
4178 error(1218, ERR_Severe, gbl.lineno, "A VALUE", CNULL);
4179 for (itemp = SST_BEGG(RHS(5)); itemp != ITEM_END; itemp = itemp->next) {
4180 sptr = ref_ident_inscope(itemp->t.sptr);
4181 PASSBYVALP(sptr, 1);
4182 PASSBYREFP(sptr, 0);
4183 }
4184 SST_ASTP(LHS, 0);
4185 break;
4186 /*
4187 * <declaration> ::= <accel begin> <accel dp stmts>
4188 */
4189 case DECLARATION62:
4190 break;
4191
4192 /* ------------------------------------------------------------------ */
4193 /*
4194 * <accel dp stmts> ::= <accel shape declstmt> |
4195 */
4196 case ACCEL_DP_STMTS1:
4197 break;
4198 /*
4199 * <accel dp stmts> ::= <accel policy declstmt>
4200 */
4201 case ACCEL_DP_STMTS2:
4202 break;
4203
4204 /* ------------------------------------------------------------------ */
4205 /*
4206 * <accel shape declstmt> ::= ACCSHAPE <accel shape dir>
4207 */
4208 case ACCEL_SHAPE_DECLSTMT1:
4209 break;
4210
4211 /* ------------------------------------------------------------------ */
4212 /*
4213 * <accel shape dir> ::= ( <accel dpvarlist> ) |
4214 */
4215 case ACCEL_SHAPE_DIR1:
4216 /*
4217 * <accel shape dir> ::= ( <accel dpvarlist> ) <accel shape attrs> |
4218 */
4219 case ACCEL_SHAPE_DIR2:
4220 break;
4221 /*
4222 * <accel shape dir> ::= '<' <ident> '>' ( <accel dpvarlist> ) |
4223 */
4224 case ACCEL_SHAPE_DIR3:
4225 /*
4226 * <accel shape dir> ::= '<' <ident> '>' ( <accel dpvarlist> ) <accel shape attrs>
4227 */
4228 case ACCEL_SHAPE_DIR4:
4229 break;
4230
4231 /* ------------------------------------------------------------------ */
4232 /*
4233 * <accel shape attrs> ::= <accel shape attrs> <accel shape attr> |
4234 */
4235 case ACCEL_SHAPE_ATTRS1:
4236 break;
4237 /*
4238 * <accel shape attrs> ::= <accel shape attr>
4239 */
4240 case ACCEL_SHAPE_ATTRS2:
4241 break;
4242
4243 /* ------------------------------------------------------------------ */
4244 /*
4245 * <accel shape attr> ::= <accel dpdefault attr> |
4246 */
4247 case ACCEL_SHAPE_ATTR1:
4248 break;
4249 /*
4250 * <accel shape attr> ::= <accel dpinit_needed attr> |
4251 */
4252 case ACCEL_SHAPE_ATTR2:
4253 break;
4254 /*
4255 * <accel shape attr> ::= <accel dptype attr>
4256 */
4257 case ACCEL_SHAPE_ATTR3:
4258 break;
4259
4260 /* ------------------------------------------------------------------ */
4261 /*
4262 * <accel dpdefault attr> ::= DEFAULT ( <ident> )
4263 */
4264 case ACCEL_DPDEFAULT_ATTR1:
4265 break;
4266
4267
4268 /* ------------------------------------------------------------------ */
4269 /*
4270 * <accel dpinit_needed attr> ::= INIT_NEEDED ( <accel dpinitvar list> )
4271 */
4272 case ACCEL_DPINIT_NEEDED_ATTR1:
4273 break;
4274
4275 /* ------------------------------------------------------------------ */
4276 /*
4277 * <accel dpinitvar list> ::= <accel dpinitvar list>, <ident> |
4278 */
4279 case ACCEL_DPINITVAR_LIST1:
4280 /*
4281 * <accel dpinitvar list> ::= <ident>
4282 */
4283 case ACCEL_DPINITVAR_LIST2:
4284 break;
4285
4286 /* ------------------------------------------------------------------ */
4287 /*
4288 * <accel dptype attr> ::= TYPE ( <ident> )
4289 */
4290 case ACCEL_DPTYPE_ATTR1:
4291 break;
4292
4293 /* ------------------------------------------------------------------ */
4294 /*
4295 * <accel policy declstmt> ::= ACCPOLICY <accel policy name> <accel policy dir>
4296 */
4297 case ACCEL_POLICY_DECLSTMT1:
4298 break;
4299
4300 /* ------------------------------------------------------------------ */
4301 /*
4302 * <accel policy name> ::= '<' <ident> '>' |
4303 */
4304 case ACCEL_POLICY_NAME1:
4305 /*
4306 * <accel policy name> ::= '<' <ident> : <ident> '>'
4307 */
4308 case ACCEL_POLICY_NAME2:
4309 break;
4310
4311 /* ------------------------------------------------------------------ */
4312 /*
4313 * <accel policy dir> ::= <accel policy attr list>
4314 */
4315 case ACCEL_POLICY_DIR1:
4316 break;
4317
4318 /* ------------------------------------------------------------------ */
4319 /*
4320 * <accel policy attr list> ::= <accel policy attr list> <accel policy attr> |
4321 */
4322 case ACCEL_POLICY_ATTR_LIST1:
4323 break;
4324 /*
4325 * <accel policy attr list> ::= <accel policy attr>
4326 */
4327 case ACCEL_POLICY_ATTR_LIST2:
4328 break;
4329
4330 /* ------------------------------------------------------------------ */
4331 /*
4332 * <accel policy attr> ::= CREATE ( <accel dpvarlist> ) |
4333 */
4334 case ACCEL_POLICY_ATTR1:
4335 break;
4336 /*
4337 * <accel policy attr> ::= NO_CREATE ( <accel dpvarlist> ) |
4338 */
4339 case ACCEL_POLICY_ATTR2:
4340 break;
4341 /*
4342 * <accel policy attr> ::= COPYIN ( <accel dpvarlist> ) |
4343 */
4344 case ACCEL_POLICY_ATTR3:
4345 break;
4346 /*
4347 * <accel policy attr> ::= COPYOUT ( <accel dpvarlist> ) |
4348 */
4349 case ACCEL_POLICY_ATTR4:
4350 break;
4351 /*
4352 * <accel policy attr> ::= COPY ( <accel dpvarlist> ) |
4353 */
4354 case ACCEL_POLICY_ATTR5:
4355 break;
4356 /*
4357 * <accel policy attr> ::= UPDATE ( <accel dpvarlist> ) |
4358 */
4359 case ACCEL_POLICY_ATTR6:
4360 break;
4361 /*
4362 * <accel policy attr> ::= DEVICEPTR ( <accel dpvarlist> ) |
4363 */
4364 case ACCEL_POLICY_ATTR7:
4365 break;
4366 /*
4367 * <accel policy attr> ::= <accel dpdefault attr> |
4368 */
4369 case ACCEL_POLICY_ATTR8:
4370 break;
4371 /*
4372 * <accel policy attr> ::= <accel dptype attr>
4373 */
4374 case ACCEL_POLICY_ATTR9:
4375 break;
4376
4377 /* ------------------------------------------------------------------ */
4378 /*
4379 * <accel dpvarlist> ::= <accel dpvarlist> <accel dpvar> |
4380 */
4381 case ACCEL_DPVARLIST1:
4382 break;
4383 /*
4384 * <accel dpvarlist> ::= <accel dpvar>
4385 */
4386 case ACCEL_DPVARLIST2:
4387 break;
4388
4389 /* ------------------------------------------------------------------ */
4390 /*
4391 * <accel dpvar> ::= <ident> |
4392 */
4393 case ACCEL_DPVAR1:
4394 /*
4395 * <accel dpvar> ::= <ident> '<' <ident> '>' |
4396 */
4397 case ACCEL_DPVAR2:
4398 /*
4399 * <accel dpvar> ::= <ident> ( <accel dpvar bnds> ) |
4400 */
4401 case ACCEL_DPVAR3:
4402 /*
4403 * <accel dpvar> ::= <ident> '<' <ident> '>' ( <accel dpvar bnds> )
4404 */
4405 case ACCEL_DPVAR4:
4406 break;
4407
4408 /* ------------------------------------------------------------------ */
4409 /*
4410 * <accel dpvar bnds> ::= <accel dpvar bnds> , <accel dpvar bnd> |
4411 */
4412 case ACCEL_DPVAR_BNDS1:
4413 break;
4414 /*
4415 * <accel dpvar bnds> ::= <accel dpvar bnd>
4416 */
4417 case ACCEL_DPVAR_BNDS2:
4418 break;
4419
4420 /* ------------------------------------------------------------------ */
4421 /*
4422 * <accel dpvar bnd> ::= <accel dp bnd> : <accel dp bnd> |
4423 */
4424 case ACCEL_DPVAR_BND1:
4425 break;
4426 /*
4427 * <accel dpvar bnd> ::= <accel dp bnd>
4428 */
4429 case ACCEL_DPVAR_BND2:
4430 break;
4431
4432 /* ------------------------------------------------------------------ */
4433 /*
4434 * <accel dp bnd> ::= <accel dp sbnd>
4435 */
4436 case ACCEL_DP_BND1:
4437 break;
4438 /*
4439 * <accel dp bnd> ::= <accel dp bndexp> |
4440 */
4441 case ACCEL_DP_BND2:
4442 break;
4443 /*
4444 * <accel dp bnd> ::= <accel dp bndexp1>
4445 */
4446 case ACCEL_DP_BND3:
4447 break;
4448
4449 /* ------------------------------------------------------------------ */
4450 /*
4451 * <accel dp bndexp> ::= <accel dp addexp> |
4452 */
4453 case ACCEL_DP_BNDEXP1:
4454 break;
4455 /*
4456 * <accel dp bndexp> ::= <accel dp mulexp>
4457 */
4458 case ACCEL_DP_BNDEXP2:
4459 break;
4460
4461 /* ------------------------------------------------------------------ */
4462 /*
4463 * <accel dp addexp> ::= <accel dp sbnd> <accel add opr> <accel dp sbnd>
4464 */
4465 case ACCEL_DP_ADDEXP1:
4466 break;
4467
4468 /* ------------------------------------------------------------------ */
4469 /*
4470 * <accel dp mulexp> ::= <accel dp sbnd> <accel mul opr> <accel dp sbnd>
4471 */
4472 case ACCEL_DP_MULEXP1:
4473 break;
4474
4475 /* ------------------------------------------------------------------ */
4476 /*
4477 * <accel add opr> ::= + |
4478 */
4479 case ACCEL_ADD_OPR1:
4480 break;
4481 /*
4482 * <accel add opr> ::= -
4483 */
4484 case ACCEL_ADD_OPR2:
4485 break;
4486
4487 /* ------------------------------------------------------------------ */
4488 /*
4489 * <accel mul opr> ::= * |
4490 */
4491 case ACCEL_MUL_OPR1:
4492 break;
4493 /*
4494 * <accel mul opr> ::= /
4495 */
4496 case ACCEL_MUL_OPR2:
4497 break;
4498
4499 /* ------------------------------------------------------------------ */
4500 /*
4501 * <accel dp bndexp1> ::= <accel dp mulexp> <accel add opr> <accel dp sbnd>
4502 */
4503 case ACCEL_DP_BNDEXP11:
4504 break;
4505
4506 /* ------------------------------------------------------------------ */
4507 /*
4508 * <accel dp sbnd> ::= <constant> |
4509 */
4510 case ACCEL_DP_SBND1:
4511 break;
4512 /*
4513 * <accel dp sbnd> ::= <ident>
4514 */
4515 case ACCEL_DP_SBND2:
4516 break;
4517
4518 /* ------------------------------------------------------------------ */
4519 /*
4520 * <routine id list> ::= <ident> |
4521 */
4522 case ROUTINE_ID_LIST1:
4523 itemp = (ITEM *)getitem(0, sizeof(ITEM));
4524 itemp->next = ITEM_END;
4525 itemp->t.sptr = SST_SYMG(RHS(1));
4526 SST_BEGP(LHS, itemp);
4527 SST_ENDP(LHS, itemp);
4528 break;
4529
4530 /*
4531 * <routine id list> ::= <routine id list> , <ident>
4532 */
4533 case ROUTINE_ID_LIST2:
4534 itemp = (ITEM *)getitem(0, sizeof(ITEM));
4535 itemp->next = ITEM_END;
4536 itemp->t.sptr = SST_SYMG(RHS(3));
4537 SST_ENDG(RHS(1))->next = itemp;
4538 SST_ENDP(LHS, itemp);
4539 break;
4540
4541 /* ------------------------------------------------------------------ */
4542 /*
4543 * <final> ::= <id>
4544 */
4545 case FINAL1:
4546 break;
4547 /* ------------------------------------------------------------------ */
4548 /*
4549 * <opt tpsl> ::= |
4550 */
4551 case OPT_TPSL1:
4552 break;
4553 /*
4554 * <opt tpsl> ::= ( <type param spec list> )
4555 */
4556 case OPT_TPSL2:
4557 sem.param_offset = 0;
4558 break;
4559 /* ------------------------------------------------------------------ */
4560 /*
4561 * <type param spec list> ::= <type param spec list> , <id> |
4562 */
4563 case TYPE_PARAM_SPEC_LIST1:
4564 rhstop = 3;
4565 goto tpsl_shared;
4566 /*
4567 * <type param spec list> ::= <id>
4568 */
4569 case TYPE_PARAM_SPEC_LIST2:
4570 rhstop = 1;
4571 tpsl_shared:
4572 sptr = SST_SYMG(RHS(rhstop));
4573 if (sem.extends && sem.param_offset == 0) {
4575 }
4576 sem.param_offset += 1;
4578 break;
4579
4580 /* ------------------------------------------------------------------ */
4581 /*
4582 * <opt derived type spec> ::= |
4583 */
4584 case OPT_DERIVED_TYPE_SPEC1:
4585 /* fall thru */
4586 /*
4587 * <opt derived type spec> ::= ( <type param decl list> )
4588 */
4589 case OPT_DERIVED_TYPE_SPEC2:
4590 break;
4591
4592 /* ------------------------------------------------------------------ */
4593 /*
4594 * <type param decl list> ::= <type param value> |
4595 */
4596 case TYPE_PARAM_DECL_LIST1:
4597 break;
4598 /*
4599 * <type param decl list> ::= <type param decl list> , <type param value>
4600 */
4601 case TYPE_PARAM_DECL_LIST2:
4602 break;
4603
4604 /* ------------------------------------------------------------------ */
4605 /*
4606 * <type param value> ::= * |
4607 */
4608 case TYPE_PARAM_VALUE5:
4609 sem.param_assume_sz = 1;
4610 sem.param_defer_len = 0;
4611 goto param_comm;
4612
4613 /*
4614 * <type param value> ::= : |
4615 */
4616 case TYPE_PARAM_VALUE3:
4617 sem.param_assume_sz = 0;
4618 sem.param_defer_len = 1;
4619 goto param_comm;
4620
4621 /*
4622 * <type param value> ::= <expression> |
4623 */
4624 case TYPE_PARAM_VALUE1:
4625 sem.param_assume_sz = 0;
4626 sem.param_defer_len = 0;
4627 param_comm:
4628 if (sem.param_offset < 0) {
4629 error(155, 3, gbl.lineno, "A non keyword = type parameter specifier "
4630 "cannot follow a keyword = type parameter "
4631 "specifier",
4632 NULL);
4633 } else {
4634 sem.param_offset += 1;
4636 mkexpr(RHS(1));
4637 ast = SST_ASTG(RHS(1));
4638 } else {
4639 ast = 0;
4640 }
4641 if (A_TYPEG(ast) == A_CNST) {
4643 ast, 1);
4644 } else {
4646 }
4647 }
4648 break;
4649 /*
4650 * <type param value> ::= <id name> = *
4651 */
4652 case TYPE_PARAM_VALUE6:
4653 sem.param_assume_sz = 1;
4654 sem.param_defer_len = 0;
4655 goto param_kwd_comm;
4656 /*
4657 * <type param value> ::= <id name> = :
4658 */
4659 case TYPE_PARAM_VALUE4:
4660 sem.param_assume_sz = 0;
4661 sem.param_defer_len = 1;
4662 goto param_kwd_comm;
4663
4664 /*
4665 * <type param value> ::= <id name> = <expression>
4666 */
4667 case TYPE_PARAM_VALUE2:
4668 sem.param_assume_sz = 0;
4669 sem.param_defer_len = 0;
4670 param_kwd_comm:
4671 np = scn.id.name + SST_CVALG(RHS(1));
4672 sem.param_offset = -1;
4674 mkexpr(RHS(3));
4675 ast = SST_ASTG(RHS(3));
4676 } else {
4677 ast = 0;
4678 }
4679 if (A_TYPEG(ast) == A_CNST) {
4681 1);
4682 } else {
4684 }
4686 /* ------------------------------------------------------------------ */
4687 /*
4688 * <opt comma> ::= |
4689 */
4690 case OPT_COMMA1:
4691 break;
4692 /*
4693 * <opt comma> ::= ,
4694 */
4695 case OPT_COMMA2:
4696 break;
4697
4698 break;
4699
4700 /* ------------------------------------------------------------------ */
4701 /*
4702 * <dimkeyword> ::= DIMENSION |
4703 */
4704 case DIMKEYWORD1:
4705 /* disallow DIMENSION in a structure */
4706 if (INSIDE_STRUCT &&
4707 (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4708 error(117, 3, gbl.lineno,
4709 STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4711 }
4712 break;
4713 /*
4714 * <dimkeyword> ::= <dimattr>
4715 */
4716 case DIMKEYWORD2:
4717 /* disallow DIMENSION in a structure */
4718 if (INSIDE_STRUCT &&
4719 (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4720 error(117, 3, gbl.lineno,
4721 STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4723 }
4724 scn.stmtyp = TK_DIMENSION;
4725 break;
4726
4727 /* ------------------------------------------------------------------ */
4728 /*
4729 * <nis> ::=
4730 */
4731 case NIS1:
4732 /* "not inside structure" test; if inside a structure emit error
4733 * message and set flag to tell parser to skip over the current
4734 * statement.
4735 */
4736 /* need to allow SEQUENCE (a hpf spec) in derived types */
4737 if (INSIDE_STRUCT &&
4738 (STSK_ENT(0).type != 'd' || scn.stmtyp != TK_SEQUENCE)) {
4739 error(117, 3, gbl.lineno,
4740 STSK_ENT(0).type == 's' ? "STRUCTURE" : "derived type", CNULL);
4742 }
4743 break;
4744
4745 /* ------------------------------------------------------------------ */
4746 /*
4747 * <data type> ::= <base type> <opt len spec> |
4748 */
4749 case DATA_TYPE1:
4750 rhstop = 2;
4751 goto data_type_shared;
4752 /*
4753 * <data type> ::= <base type> ( <len kind> ) |
4754 */
4755 case DATA_TYPE2:
4756 rhstop = 3;
4757 data_type_shared:
4759 /* probably defined in a USEd module, wait until USE stmts have been
4760 * processed */
4761 break;
4762 }
4763
4764 set_len_attributes(RHS(rhstop), 0);
4765 sem.gdtype =
4766 mod_type(sem.gdtype, sem.gty, lenspec[0].kind, lenspec[0].len, 0, 0);
4767 break;
4768 /*
4769 * <data type> ::= CLASS <pgm> ( * )
4770 */
4771 case DATA_TYPE5:
4773#if DEBUG
4774 assert(DTY(DTYPEG(sptr)) == TY_DERIVED && UNLPOLYG(DTY(DTYPEG(sptr) + 3)),
4775 "semant1: Invalid dtype for CLASS(*)", 0, 3);
4776#endif
4777 sem.class = 1;
4778 goto type_common;
4779
4780 /*
4781 * <data type> ::= CLASS <pgm> ( <id> <opt derived type spec> )
4782 */
4783 case DATA_TYPE4:
4784 sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER);
4785 sem.class = 1;
4786 goto type_common;
4787 /*
4788 * <data type> ::= TYPE ( <id> <opt derived type spec> )
4789 */
4790 case DATA_TYPE3:
4791 sptr = refsym((int)SST_SYMG(RHS(3)), OC_OTHER);
4792 type_common:
4793 if (STYPEG(sptr) != ST_TYPEDEF) {
4794 if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) {
4795 sptr = GTYPEG(sptr);
4796 } else if (STYPEG(sptr) == ST_UNKNOWN && sem.pgphase == PHASE_INIT) {
4799 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4800 } else if (STYPEG(sptr) == ST_UNKNOWN &&
4801 (scn.stmtyp == TK_IMPLICIT ||
4802 (INSIDE_STRUCT && STSK_ENT(0).type == 'd'))) {
4803 /* assume a forward reference -- legal if the type
4804 * appears in an implicit statement or is a component
4805 * declaration with the POINTER attribute or if phase is
4806 * PHASE_INIT (in which case it could be a function return
4807 * type).
4808 */
4809 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4810 dtype = get_type(6, TY_DERIVED, NOSYM);
4811 DTYPEP(sptr, dtype);
4812 DTY(dtype + 2) = 0; /* will be filled in */
4813 DTY(dtype + 3) = sptr;
4814 DTY(dtype + 5) = 0;
4815 } else {
4816 /* recover by creating an empty typedef */
4817 error(155, 3, gbl.lineno, "Derived type has not been declared -",
4818 SYMNAME(sptr));
4819 sptr = insert_sym(sptr);
4820 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
4821 dtype = get_type(6, TY_DERIVED, NOSYM);
4822 DTYPEP(sptr, dtype);
4823 DTY(dtype + 2) = 0; /* will be filled in */
4824 DTY(dtype + 3) = sptr;
4825 DTY(dtype + 5) = 0;
4826 }
4827 }
4828
4829 else if (DTY(DTYPEG(sptr) + 1) <= NOSYM &&
4830 (!INSIDE_STRUCT || STSK_ENT(0).type != 'd')) {
4831 int tag;
4832 tag = DTY(DTYPEG(sptr) + 3);
4833 } else if (!sem.class && ABSTRACTG(sptr)) {
4834 error(155, 3, gbl.lineno, "illegal use of abstract type", SYMNAME(sptr));
4835 }
4836 if (!sem.type_mode || sem.stag_dtype != DTYPEG(sptr)) {
4837/* Do not call defer_put_kind_type_param() if this declaration
4838 * is part of a recursively typed component. The
4839 * defer_put_kind_type_param() call below processes all type parameters.
4840 * But in this case, the type has not yet been fully defined. So, we
4841 * need to handle this later.
4842 */
4843 sem.stag_dtype = DTYPEG(sptr);
4846 } else {
4847 sem.stag_dtype = DTYPEG(sptr);
4849 }
4850 defer_put_kind_type_param(0, 0, NULL, 0, 0, 0);
4852 defer_pt_decl(0, 2)) {
4853 /* In this case we're using just the default type
4854 * of a parameterized derived type. We need to make sure we
4855 * create another instance of it so we don't pollute the
4856 * default type that's shared across all instances of the type
4857 * (e.g., type(t) :: x may pollute type(t(5)) :: y ).
4858 */
4860 }
4865 break;
4866
4867 /* ------------------------------------------------------------------ */
4868 /*
4869 * <type spec> ::= <intrinsic type>
4870 */
4871 case TYPE_SPEC1:
4872 break;
4873 /*
4874 * <type spec> ::= <ident>
4875 */
4876 case TYPE_SPEC2:
4878 break;
4879
4880 /* ------------------------------------------------------------------ */
4881 /*
4882 * <intrinsic type> ::= <base type> <opt len spec> |
4883 */
4884 case INTRINSIC_TYPE1:
4885 rhstop = 2;
4886 if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) {
4887 if (SST_IDG(RHS(2)) == 0) {
4888 if (SST_ASTG(RHS(2)))
4889 sem.gcvlen = SST_ASTG(RHS(2));
4890 else if (SST_SYMG(RHS(2)) == -2 || SST_SYMG(RHS(2)) == -1)
4891 sem.gcvlen = astb.i1;
4892 else
4893 sem.gcvlen = mk_cval(SST_SYMG(RHS(2)), DT_INT4);
4894
4895 } else {
4896 sem.gcvlen = SST_ASTG(RHS(2));
4897 }
4898 }
4899 goto intrinsic_type_shared;
4900 /*
4901 * <intrinsic type> ::= <base type> ( <len kind> )
4902 */
4903 case INTRINSIC_TYPE2:
4904 rhstop = 3;
4905 if (sem.gdtype == DT_CHAR || sem.gdtype == DT_NCHAR) {
4906 if (SST_IDG(RHS(3)) == 0) {
4907 if (SST_ASTG(RHS(3)))
4908 sem.gcvlen = SST_ASTG(RHS(3));
4909 else if (SST_SYMG(RHS(3)) == -2 || SST_SYMG(RHS(3)) == -1)
4910 sem.gcvlen = astb.i1;
4911 else
4912 sem.gcvlen = mk_cval(SST_SYMG(RHS(3)), DT_INT4);
4913
4914 } else {
4915 sem.gcvlen = SST_ASTG(RHS(3));
4916 }
4917 }
4918
4919 intrinsic_type_shared:
4920 if (is_exe_stmt && sem.which_pass == 0)
4921 break;
4922 if (sem.deferred_func_len) {
4923 /* probably defined in a USEd module, wait USE stmts have been processed
4924 */
4925 break;
4926 }
4927 set_aclen(RHS(rhstop), 1, 1);
4928 sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
4929 lenspec[1].propagated, 0);
4931 set_aclen(RHS(rhstop), 1, 0);
4932 SST_IDP(LHS, 0);
4933 break;
4934
4935 /* ------------------------------------------------------------------ */
4936 /*
4937 * <base type> ::= INTEGER |
4938 */
4939 case BASE_TYPE1:
4941 sem.gty = TY_INT;
4942 break;
4943 /*
4944 * <base type> ::= REAL |
4945 */
4946 case BASE_TYPE2:
4948 sem.gty = TY_REAL;
4949 break;
4950 /*
4951 * <base type> ::= DOUBLEPRECISION |
4952 */
4953 case BASE_TYPE3:
4955 sem.gty = TY_DBLE;
4956 if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_QUAD) {
4957 error(437, 2, gbl.lineno, "DOUBLE PRECISION", "REAL");
4958 sem.gdtype = DT_REAL;
4959 }
4960 break;
4961 /*
4962 * <base type> ::= COMPLEX |
4963 */
4964 case BASE_TYPE4:
4966 sem.gty = TY_CMPLX;
4967 break;
4968 /*
4969 * <base type> ::= DOUBLECOMPLEX |
4970 */
4971 case BASE_TYPE5:
4972 if (flg.standard)
4973 error(171, 2, gbl.lineno, "DOUBLECOMPLEX", CNULL);
4975 sem.gty = TY_DCMPLX;
4976 if (XBIT(57, 0x10) && DTY(sem.gdtype) == TY_DCMPLX) {
4977 error(437, 2, gbl.lineno, "DOUBLE COMPLEX", "COMPLEX");
4979 }
4980 break;
4981 /*
4982 * <base type> ::= LOGICAL |
4983 */
4984 case BASE_TYPE6:
4986 sem.gty = TY_LOG;
4987 break;
4988 /*
4989 * <base type> ::= CHARACTER |
4990 */
4991 case BASE_TYPE7:
4992 sem.gdtype = sem.ogdtype = DT_CHAR;
4993 sem.gty = TY_CHAR;
4994 break;
4995 /*
4996 * <base type> ::= NCHARACTER |
4997 */
4998 case BASE_TYPE8:
4999 if (flg.standard)
5000 error(171, 2, gbl.lineno, "NCHARACTER", CNULL);
5001 sem.gdtype = sem.ogdtype = DT_NCHAR;
5002 sem.gty = TY_NCHAR;
5003 break;
5004 /*
5005 * <base type> ::= BYTE
5006 */
5007 case BASE_TYPE9:
5008 if (flg.standard)
5009 error(171, 2, gbl.lineno, "BYTE", CNULL);
5010 sem.gdtype = sem.ogdtype = DT_BINT;
5011 sem.gty = TY_BINT;
5012 break;
5013
5014 /* ------------------------------------------------------------------ */
5015 /*
5016 * <opt len spec> ::= |
5017 */
5018 case OPT_LEN_SPEC1:
5019 SST_IDP(LHS, 0);
5020 SST_SYMP(LHS, -1);
5021 SST_ASTP(LHS, 0);
5023 break;
5024 /*
5025 * <opt len spec> ::= * <len spec>
5026 */
5027 case OPT_LEN_SPEC2:
5028 *LHS = *RHS(2);
5029 if (sem.ogdtype != DT_CHAR && flg.standard)
5030 errwarn(173);
5031 break;
5032
5033 /*
5034 * <opt len spec> ::= : <len spec>
5035 */
5036 case OPT_LEN_SPEC3:
5037 *LHS = *RHS(2);
5038 if (sem.ogdtype != DT_CHAR && flg.standard)
5039 errwarn(173);
5040 break;
5041
5042 /* ------------------------------------------------------------------ */
5043 /*
5044 * <len spec> ::= <integer> |
5045 */
5046 case LEN_SPEC1: /* constant value set by scan */
5047 SST_IDP(LHS, 0); /* flag that an expression was seen */
5048 SST_ASTP(LHS, 0);
5049 goto len_spec;
5050 /*
5051 * <len spec> ::= ( <tpv> ) |
5052 */
5053 case LEN_SPEC2:
5054 *LHS = *RHS(2);
5055 char_len_spec:
5056 if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR)
5057 SST_SYMP(LHS, 0);
5058 len_spec:
5059 if (is_exe_stmt && sem.which_pass == 0)
5060 break;
5061 if (sem.ogdtype == DT_CHAR || sem.ogdtype == DT_NCHAR) {
5062 if (SST_IDG(LHS) == 0) {
5063 if (SST_CVALG(LHS) <= 0) {
5064 /* zero-size character - set flag */
5065 SST_SYMP(LHS, -2);
5066 }
5067 }
5068 break;
5069 }
5070 if (SST_IDG(LHS) == 0 && SST_SYMG(LHS) <= 0) {
5071 /* Cause error message to print later when context is known,
5072 * ensure that illegal value -1 doesn't map to internal
5073 * flag -1 for no length spec.
5074 */
5075 SST_SYMP(LHS, 99); /* cause error message displayed later */
5076 }
5077 break;
5078
5079 /* ------------------------------------------------------------------ */
5080 /*
5081 * <tpv> ::= <expression> |
5082 */
5083 case TPV1:
5084 if (is_exe_stmt && sem.which_pass == 0)
5085 break;
5086 if (chk_kind_parm(RHS(1))) {
5087 mkexpr(RHS(1)); /* Needed for type parameter */
5088 ast = SST_ASTG(RHS(1));
5089 switch (A_TYPEG(ast)) {
5090 case A_ID:
5091 case A_LABEL:
5092 case A_ENTRY:
5093 case A_SUBSCR:
5094 case A_SUBSTR:
5095 case A_MEM:
5096 /* Mark possible use of type parameter */
5097 sptr = sym_of_ast(ast);
5098 KINDP(sptr, -1);
5099 break;
5100 }
5101 }
5102 rhstop = 5;
5103 if (sem.ogdtype != DT_CHAR && sem.ogdtype != DT_NCHAR) {
5104 int offset;
5105 if (sem.pgphase <= PHASE_USE) {
5106 if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) {
5107 /* probably defined in a USEd module, wait until USE stmts
5108 * have been processed */
5109 ast = SST_ASTG(RHS(1));
5110 if (!ast) {
5111 ast = mk_id(SST_SYMG(top));
5112 }
5115 break;
5116 } else if (SST_IDG(top) == S_EXPR) {
5119 break;
5120 }
5121 }
5122 offset = chk_kind_parm(RHS(1));
5123 if (offset) {
5124 /* TO DO: Save length expression candidate like in DT_CHAR case */
5126 SST_SYMP(LHS, 4); /* place holder */
5127 sem.kind_candidate = (ITEM *)getitem(0, sizeof(ITEM));
5128 sem.kind_candidate->t.stkp = (SST *)getitem(0, sizeof(SST));
5129 *(sem.kind_candidate->t.stkp) = *RHS(1);
5130 } else
5131 SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE));
5132 } else {
5133 int offset;
5134 offset = chk_kind_parm(RHS(1));
5135 if (offset) {
5137 sem.len_candidate = (ITEM *)getitem(0, sizeof(ITEM));
5138 sem.len_candidate->t.stkp = (SST *)getitem(0, sizeof(SST));
5139 *(sem.len_candidate->t.stkp) = *RHS(1);
5140 SST_SYMP(LHS, 1); /* place holder */
5141 SST_IDP(LHS, 0); /* flag that a constant was seen */
5142 SST_ASTP(LHS, 0); /* not expression */
5143 break;
5144 }
5145 sem.len_candidate = 0;
5146 constant_lvalue(RHS(1));
5147 if (SST_IDG(RHS(1)) == S_CONST) {
5148 SST_SYMP(LHS, chkcon(RHS(1), DT_INT4, TRUE));
5149 } else {
5150 (void)chktyp(RHS(1), DT_INT, TRUE);
5151 ast = SST_ASTG(RHS(1));
5152 /* flag that an expression was seen: id field is 1, sym field
5153 * is non-zero, and ast field is the ast of the expression.
5154 */
5155 if (sem.pgphase == PHASE_INIT) {
5156 if (SST_IDG(top) == S_IDENT && STYPEG(SST_SYMG(top)) == ST_UNKNOWN) {
5157 /* probably defined in a USEd module,
5158 * wait until USE stmts have been processed */
5159 if (!ast) {
5160 ast = mk_id(SST_SYMG(top));
5161 }
5164 break;
5165 } else if (SST_IDG(top) == S_EXPR) {
5168 break;
5169 }
5170 }
5171
5172 SST_IDP(LHS, 1);
5174 SST_ASTP(LHS, SST_ASTG(RHS(1)));
5175 break;
5176 }
5177 }
5178
5179 SST_IDP(LHS, 0); /* flag that a constant was seen */
5180 SST_ASTP(LHS, 0); /* not expression */
5181 break;
5182 /*
5183 * <tpv> ::= *
5184 */
5185 case TPV2:
5186 /* flag that a '*' was seen: id field is 1, sym field is zero. */
5187 SST_IDP(LHS, 1);
5188 SST_SYMP(LHS, 0);
5189 SST_ASTP(LHS, 0); /* not expression */
5190 break;
5191 /*
5192 * <tpv> ::= :
5193 */
5194 case TPV3:
5195 /* flag that a ':' was seen: id field is 1, sym field is -1. */
5196 SST_IDP(LHS, 1);
5197 SST_SYMP(LHS, -1);
5198 SST_ASTP(LHS, 0); /* not expression */
5199 break;
5200
5201 /* ------------------------------------------------------------------ */
5202 /*
5203 * <len kind> ::= <tpv> |
5204 */
5205 case LEN_KIND1:
5206 if (is_exe_stmt && sem.which_pass == 0)
5207 break;
5208 if (sem.deferred_func_kind) {
5209 /* probably defined in a USEd module, wait USE stmts have been processed
5210 */
5211 break;
5212 }
5213
5214 if (sem.gdtype != DT_CHAR && sem.gdtype != DT_NCHAR) {
5216 SST_SYMP(LHS, -1);
5217 break;
5218 }
5219 goto len_spec;
5220 /*
5221 * <len kind> ::= <len kind spec> |
5222 */
5223 case LEN_KIND2:
5224 if (is_exe_stmt && sem.which_pass == 0)
5225 break;
5226 switch (SST_FLAGG(RHS(1))) {
5227 case 0: /* error */
5228 break;
5229 case 1: /* LEN = */
5230 if (sem.ogdtype == DT_CHAR)
5231 goto char_len_spec;
5232 error(81, 3, gbl.lineno,
5233 "- LEN = cannot be specified with non-character type", CNULL);
5234 break;
5235 case 2: /* KIND = */
5237 break;
5238 }
5239 SST_SYMP(LHS, -1);
5240 break;
5241 /*
5242 * <len kind> ::= <tpv> , <len kind spec>|
5243 */
5244 case LEN_KIND3: /* len, kind = ... */
5245 if (is_exe_stmt && sem.which_pass == 0)
5246 break;
5247 if (sem.ogdtype != DT_CHAR) {
5248 error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5249 SST_SYMP(LHS, -1); /* an error occurred - null processing */
5250 break;
5251 }
5252 switch (SST_FLAGG(RHS(3))) {
5253 case 0: /* error */
5254 break;
5255 case 1: /* LEN = */
5256 error(81, 3, gbl.lineno, "- Repeated LEN", CNULL);
5257 break;
5258 case 2: /* KIND = */
5260 break;
5261 }
5262 goto char_len_spec;
5263 /*
5264 * <len kind> ::= <tpv> , <tpv> |
5265 */
5266 case LEN_KIND4: /* len, kind */
5267 if (is_exe_stmt && sem.which_pass == 0)
5268 break;
5269 if (sem.ogdtype != DT_CHAR) {
5270 error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5271 SST_SYMP(LHS, -1); /* an error occurred - null processing */
5272 break;
5273 }
5275 goto char_len_spec;
5276 /*
5277 * <len kind> ::= <len kind spec> , <len kind spec>
5278 */
5279 case LEN_KIND5: /* len = .., kind = ... or kind = ..., len = ... */
5280 if (is_exe_stmt && sem.which_pass == 0)
5281 break;
5282 if (sem.ogdtype != DT_CHAR) {
5283 error(81, 3, gbl.lineno, "- LEN and KIND with non-character type", CNULL);
5284 SST_SYMP(LHS, -1); /* an error occurred - null processing */
5285 break;
5286 }
5287 switch (SST_FLAGG(RHS(1))) {
5288 default: /* error */
5289 break;
5290 case 1: /* LEN = */
5291 switch (SST_FLAGG(RHS(3))) {
5292 case 0: /* error */
5293 break;
5294 case 1: /* LEN = */
5295 error(81, 3, gbl.lineno, "- Repeated LEN =", CNULL);
5296 break;
5297 case 2: /* KIND = */
5299 goto char_len_spec;
5300 }
5301 break;
5302 case 2: /* KIND = */
5303 switch (SST_FLAGG(RHS(3))) {
5304 case 0: /* error */
5305 break;
5306 case 1: /* LEN = */
5308 *LHS = *RHS(3);
5309 goto char_len_spec;
5310 case 2: /* KIND = */
5311 error(81, 3, gbl.lineno, "- Repeated KIND =", CNULL);
5312 break;
5313 }
5314 break;
5315 }
5316 SST_SYMP(LHS, -1); /* an error occurred - null processing */
5317 break;
5318
5319 /* ------------------------------------------------------------------ */
5320 /*
5321 * <len kind spec> ::= <id name> = <tpv>
5322 */
5323 case LEN_KIND_SPEC1:
5324 np = scn.id.name + SST_CVALG(RHS(1));
5325 *LHS = *RHS(3);
5326 if (is_exe_stmt && sem.which_pass == 0)
5327 break;
5328 SST_FLAGP(LHS, 0);
5329 if (sem_strcmp(np, "len") == 0) {
5330 SST_FLAGP(LHS, 1);
5336 if (A_TYPEG(ast) != A_CNST) {
5337 /* set ignore flag on any len type parameters to prevent
5338 * "implicit none" errors
5339 */
5340 chk_len_parm_expr(ast, 0, 1);
5341 }
5342 }
5343 } else if (sem_strcmp(np, "kind") == 0) {
5346 if (!sem.deferred_func_kind) {
5347 if (SST_IDG(RHS(3))) {
5348 if (SST_ASTG(RHS(3)))
5349 errsev(87);
5350 else
5351 error(81, 3, gbl.lineno, "- KIND = *", CNULL);
5352 } else
5353 SST_FLAGP(LHS, 2);
5354 }
5355 } else {
5356 error(34, 3, gbl.lineno, np, CNULL);
5357 }
5358 break;
5359
5360 /* ------------------------------------------------------------------ */
5361 /*
5362 * <optional comma> ::= |
5363 */
5364 case OPTIONAL_COMMA1:
5365 break;
5366 /*
5367 * <optional comma> ::= ,
5368 */
5369 case OPTIONAL_COMMA2:
5370 break;
5371
5372 /* ------------------------------------------------------------------ */
5373 /*
5374 * <opt attr> ::= |
5375 */
5376 case OPT_ATTR1:
5377 break;
5378 /*
5379 * <opt attr> ::= ::
5380 */
5381 case OPT_ATTR2:
5382 break;
5383
5384 /* ------------------------------------------------------------------ */
5385 /*
5386 * <typdcl list> ::= <typdcl list> , <typdcl item> |
5387 */
5388 case TYPDCL_LIST1:
5389 break;
5390 /*
5391 * <typdcl list> ::= <typdcl item>
5392 */
5393 case TYPDCL_LIST2:
5394 break;
5395
5396 /* ------------------------------------------------------------------ */
5397 /*
5398 * <typdcl item> ::= <dcl id> / <dinit const list> / |
5399 */
5400 case TYPDCL_ITEM1:
5401 if (flg.standard)
5402 errwarn(174);
5403 inited = TRUE;
5404 goto typ_dcl_item;
5405 /*
5406 * <typdcl item> ::= <dcl id>
5407 */
5408 case TYPDCL_ITEM2:
5409 inited = FALSE;
5410 typ_dcl_item:
5411 sptr = SST_SYMG(RHS(1));
5412 if (flg.xref)
5413 xrefput(sptr, 'd');
5414 dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
5415 lenspec[1].propagated, sptr);
5416 if (!DCLDG(sptr)) {
5417 switch (STYPEG(sptr)) {
5418 /* any cases for which a type must be identical to the variable's
5419 * implicit type.
5420 */
5421 case ST_PARAM:
5422 if (DTYPEG(sptr) != dtype)
5423 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5424 break;
5425 default:
5426 break;
5427 }
5428 }
5429 common_typespecs:
5430 if (DCLDG(sptr)) {
5431 switch (STYPEG(sptr)) {
5432 /* any cases for which a data type does not apply */
5433 case ST_MODULE:
5434 case ST_NML:
5435 error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5436 break;
5437 default:
5438 /* data type for ident has already been specified */
5439 if (DDTG(DTYPEG(sptr)) == dtype)
5440 error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5441 else if (DTY(DTYPEG(sptr)) == TY_PTR &&
5442 DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC &&
5443 DTY(DTY(DTYPEG(sptr) + 1) + 1) == DT_NONE &&
5444 DTY(DTY(DTYPEG(sptr) + 1) + 2) == 0) {
5445 /* ptr to procedure, return dtype is DT_NONE, no interface; just
5446 * update the return dtype (no longer assume it's a pointer to a
5447 * subroutine).
5448 */
5449 DTY(DTY(DTYPEG(sptr) + 1) + 1) = dtype;
5450 } else {
5451 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5452 }
5453 }
5454 break; /* to avoid setting symbol table entry's stype field */
5455 }
5456
5457 DCLDP(sptr, TRUE);
5458
5459 /* Procedure pointer without a declared type (combination of "external" and
5460 * "pointer" attributes) */
5461 if (is_procedure_ptr_dtype(DTYPEG(sptr))) {
5463 /* Avoid the rest */
5464 break;
5465 }
5466
5467 /* Procedure without a type ("external" attribute) */
5468 if (is_procedure_dtype(DTYPEG(sptr))) {
5470 /* Avoid the rest */
5471 break;
5472 }
5473
5475 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
5476 DTY(DTYPEG(sptr) + 1) = dtype;
5477 if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) &&
5478 DISTMEMG(DTY(dtype + 3))) {
5479 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5480 }
5481 } else {
5482 DTYPEP(sptr, dtype);
5483 }
5484 if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr)) {
5485#if DEBUG
5486 interr("semant1: data type set for ST_ENTRY with FVAL", sptr, 3);
5487#endif
5488 DCLDP(FVALG(sptr), TRUE);
5489 DTYPEP(FVALG(sptr), DTYPEG(sptr));
5490 set_char_attributes(FVALG(sptr), &dtype);
5491 }
5492 if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
5493 RESULTG(sptr)) {
5494 /* set the type for the entry point as well */
5496 }
5497 if (inited) { /* check if symbol is data initialized */
5498 gen_dinit(sptr, RHS(3));
5499 } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) &&
5500 !ADJARRG(sptr) && !ALLOCG(sptr) && SCG(sptr) != SC_DUMMY) {
5501 int dt_dtype = DDTG(dtype);
5502 if (INSIDE_STRUCT) {
5503 /* Uninitialized declaration of a derived type data item.
5504 * Check for and handle any component intializations defined
5505 * for this derived type */
5506 build_typedef_init_tree(sptr, dt_dtype);
5507 } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) &&
5508 SCOPEG(sptr) == stb.curr_scope &&
5509 STYPEG(stb.curr_scope) == ST_MODULE) {
5510 /*
5511 * a derived type module variable has component initializers,
5512 * so generate inits.
5513 */
5514 build_typedef_init_tree(sptr, dt_dtype);
5515 }
5516 }
5517
5518 break;
5519
5520 /*
5521 * <typdcl item> ::= %FILL
5522 */
5523 case TYPDCL_ITEM3:
5524 if (flg.standard)
5525 error(176, 2, gbl.lineno, "%FILL", CNULL);
5526 if (sem.stsk_depth == 0)
5527 errwarn(145);
5528 break;
5529
5530 /* ------------------------------------------------------------------ */
5531 /*
5532 * <dcl id list> ::= <dcl id list> , <dcl id> |
5533 */
5534 case DCL_ID_LIST1:
5535 rhstop = 3;
5536 goto dcl_id_list;
5537 /*
5538 * <dcl id list> ::= <dcl id> |
5539 */
5540 case DCL_ID_LIST2:
5541 rhstop = 1;
5542 /* Shared by DIMENSION and COMMON statements */
5543 dcl_id_list:
5544 sptr = SST_SYMG(RHS(rhstop));
5545 if (lenspec[1].kind)
5546 error(32, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5547 if (flg.xref)
5548 xrefput(sptr, 'd');
5549 if (scn.stmtyp == TK_COMMON) {
5550 /* COMMON block defn: link symbol into list */
5551 {
5552 itemp = (ITEM *)getitem(0, sizeof(ITEM));
5553 itemp->next = ITEM_END;
5554 itemp->t.sptr = sptr;
5555 if (rhstop == 1)
5556 /* adding first common block item to list: */
5557 SST_BEGP(LHS, itemp);
5558 else
5559 SST_ENDG(RHS(1))->next = itemp;
5560 }
5561 SST_ENDP(LHS, itemp);
5562 } else {
5563#if DEBUG
5564 assert(scn.stmtyp == TK_DIMENSION, "semant:unexp.stmt-dcl_id_lis",
5565 scn.stmtyp, 3);
5566#endif
5567 }
5568 break;
5569
5570 /* ------------------------------------------------------------------ */
5571 /*
5572 * <dcl id> ::= <ident> <opt len spec> |
5573 */
5574 case DCL_ID1:
5575 set_len_attributes(RHS(2), 1);
5576 stype = ST_IDENT;
5577 sptr = SST_SYMG(RHS(1));
5578 if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr))
5579 sptr = FVALG(sptr);
5580 if (test_scope(sptr) == sem.scope_level && STYPEG(sptr) != ST_MEMBER) {
5581 dtype = DTYPEG(sptr);
5582 } else {
5583 dtype = 0;
5584 }
5585 sem.dinit_count = 1;
5586 goto dcl_shared;
5587 /*
5588 * <dcl id> ::= <ident> <opt len spec> <dim beg> <dimension list> ) <opt
5589 * len spec>
5590 */
5591 case DCL_ID2:
5592 /* Send len spec up with ident on semantic stack */
5593 if (SST_SYMG(RHS(6)) != -1) {
5594 if (SST_SYMG(RHS(2)) != -1)
5595 errsev(46);
5596 set_len_attributes(RHS(6), 1);
5597 } else
5598 set_len_attributes(RHS(2), 1);
5599 stype = ST_ARRAY;
5600 dtype = SST_DTYPEG(RHS(4));
5601 ad = AD_DPTR(dtype);
5602 if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface)
5603 sem.dinit_count = -1;
5604 else
5606 dcl_shared:
5607 sptr = SST_SYMG(RHS(1));
5608 if (!(entity_attr.exist & ET_B(ET_BIND))) {
5610 SST_SYMP(RHS(1), sptr);
5611 }
5612 if (!sem.which_pass && gbl.internal > 1) {
5614 }
5619 }
5620 if (INSIDE_STRUCT) {
5621 if (STYPEG(sptr) != ST_UNKNOWN)
5623 if (sem.kind_type_param) {
5624 USEKINDP(sptr, 1);
5625 KINDP(sptr, sem.kind_type_param);
5626 if (sem.kind_candidate) {
5627 /* Save kind expression in component */
5629 KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp));
5630 }
5631 }
5632 if (sem.len_type_param) {
5633 USELENP(sptr, 1);
5634 LENP(sptr, sem.len_type_param);
5635 }
5636 SYMLKP(sptr, NOSYM);
5637 STYPEP(sptr, ST_MEMBER);
5638 /* if the dtype was determined from the symbol table entry then it
5639 * is incorrect (because we got a new symbol entry above).
5640 */
5641 if (stype == ST_IDENT)
5642 dtype = sem.gdtype;
5643
5644 if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED &&
5645 (STSK_ENT(0).type == 'd')) {
5646 stsk = &STSK_ENT(0);
5647 /* if outer derived type has SEQUENCE then nested one should */
5648 if (SEQG(DTY(stsk->dtype + 3)) && !SEQG(DTY(sem.gdtype + 3))) {
5649 error(155, 3, gbl.lineno,
5650 "SEQUENCE must be set for nested derived type",
5651 SYMNAME(DTY(sem.gdtype + 3)));
5652 }
5653 if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) {
5654 error(155, 3, gbl.lineno,
5655 "Derived type component must have the POINTER attribute -",
5656 SYMNAME(sptr));
5657 } else if (!DCLDG(DTY(sem.gdtype + 3)))
5658 error(155, 3, gbl.lineno, "Derived type has not been declared -",
5659 SYMNAME(DTY(sem.gdtype + 3)));
5660 }
5661
5662 DTYPEP(sptr, dtype); /* must be done before link members */
5663 /* link field-namelist into member list at this level */
5664 stsk = &STSK_ENT(0);
5666 if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' &&
5667 (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)))
5668 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5669 if (DTY(dtype) == TY_ARRAY) {
5670 int d;
5671 d = DTY(dtype + 1);
5672 if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
5673 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5674 }
5675 if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad)) {
5676 if (!ALLOCG(sptr) && AD_ADJARR(ad)) {
5677 int bndast, badArray;
5678 int numdim = AD_NUMDIM(ad);
5679 for (badArray = i = 0; i < numdim; i++) {
5680 bndast = AD_LWAST(ad, i);
5681 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
5682 if (!badArray) {
5683 bndast = AD_UPAST(ad, i);
5684 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
5685 if (!badArray) {
5686 ADJARRP(sptr, 1);
5687 USELENP(sptr, 1);
5688 break;
5689 }
5690 }
5691 }
5692 if (badArray) {
5693 for (badArray = i = 0; i < numdim; i++) {
5694 bndast = AD_LWAST(ad, i);
5695 badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
5696 if (badArray) {
5697 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
5698 if (!badArray) {
5699 ADJARRP(sptr, 1);
5700 USELENP(sptr, 1);
5701 break;
5702 }
5703 }
5704 if (badArray)
5705 goto illegal_array_member;
5706 bndast = AD_UPAST(ad, i);
5707 badArray = !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
5708 if (badArray) {
5709 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
5710 if (!badArray) {
5711 ADJARRP(sptr, 1);
5712 USELENP(sptr, 1);
5713 break;
5714 }
5715 } else if (A_TYPEG(bndast) != A_ID &&
5716 A_TYPEG(bndast) != A_CNST) {
5717
5718 ADJARRP(sptr, 1);
5719 USELENP(sptr, 1);
5720 if (!chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1)) {
5721 USEKINDP(sptr, 1);
5722 }
5723 break;
5724 }
5725 if (badArray)
5726 goto illegal_array_member;
5727 }
5728 }
5729 } else if (!ALLOCG(sptr)) {
5730 illegal_array_member:
5731 error(134, 3, gbl.lineno,
5732 "- deferred shape array must have the POINTER "
5733 "attribute in a derived type",
5734 SYMNAME(sptr));
5735 ALLOCP(sptr, 1);
5736 }
5737 }
5738 }
5739 if (XBIT(58, 0x10000) && !F90POINTERG(sptr)) {
5740 /* we are processing a member, and we must handle all pointers
5741 * do we need descriptors for this member? */
5742 if (POINTERG(sptr) || ALLOCG(sptr) ||
5743#ifdef USELENG
5744 USELENG(sptr) ||
5745#endif
5746 (STYPEG(sptr) != ST_MEMBER && (ADJARRG(sptr) || RUNTIMEG(sptr)))) {
5749 SCP(sptr, SC_BASED);
5750 }
5751 }
5752 } else {
5753 sptr = create_var(sptr);
5754 SST_SYMP(LHS, sptr);
5755 stype1 = STYPEG(sptr);
5756 if (sem.kind_type_param) {
5757 USEKINDP(sptr, 1);
5758 KINDP(sptr, sem.kind_type_param);
5759 }
5760 if (sem.len_type_param) {
5761 USELENP(sptr, 1);
5762 LENP(sptr, sem.len_type_param);
5763 }
5764
5765 if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) {
5766 /* TBD - Probably need to fix this condition when we
5767 * support unlimited polymorphic entities.
5768 */
5769 if (SCG(sptr) == SC_DUMMY || POINTERG(sptr) || ALLOCG(sptr)) {
5770 CLASSP(sptr, 1); /* mark polymorphic variable */
5771 if (PASSBYVALG(sptr)) {
5772 error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE "
5773 "attribute -",
5774 SYMNAME(sptr));
5775 }
5776 if (DTY(sem.stag_dtype) == TY_DERIVED) {
5777 int tag = DTY(sem.stag_dtype + 3);
5778 if (CFUNCG(tag)) {
5779 error(155, 3, gbl.lineno,
5780 "Polymorphic variable cannot be declared "
5781 "with a BIND(C) derived type - ",
5782 SYMNAME(sptr));
5783 }
5784 if (SEQG(tag)) {
5785 error(155, 3, gbl.lineno,
5786 "Polymorphic variable cannot be declared "
5787 "with a SEQUENCE derived type - ",
5788 SYMNAME(sptr));
5789 }
5790 }
5791
5792 } else {
5793 error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, "
5794 "allocatable, or dummy object - ",
5795 SYMNAME(sptr));
5796 }
5797 }
5798 if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass &&
5799 !(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) &&
5800 SCG(sptr) != SC_DUMMY && !FVALG(sptr) &&
5801 (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr))) {
5803 }
5804 if (dtype == 0)
5805 dtype = DTYPEG(sptr);
5806 /* Assertion:
5807 * stype = stype we want to make symbol {ARRAY,STRUCT,or IDENT}
5808 * stype1 = symbol's current stype
5809 */
5810 if (stype == ST_ARRAY) {
5811 if (IS_INTRINSIC(stype1)) {
5812 /* Changing intrinsic symbol to ARRAY */
5813 if ((sptr = newsym(sptr)) == 0)
5814 /* Symbol frozen as an intrinsic, ignore type decl */
5815 break;
5816 SST_SYMP(LHS, sptr);
5817 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5818 stype1 = ST_UNKNOWN;
5819 } else
5820 switch (stype1) {
5821 case ST_UNKNOWN:
5822 case ST_IDENT:
5823 case ST_VAR:
5824 case ST_STRUCT:
5825 break;
5826 case ST_ENTRY:
5827 if (DTY(DTYPEG(sptr)) != TY_ARRAY)
5828 break;
5829 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5830 goto dcl_shared_end;
5831 case ST_ARRAY: {
5832 /* if symbol is already an array, check if the
5833 * dimension specifiers are identical.
5834 */
5835 ADSC *ad1, *ad2;
5836 int ndim;
5837
5838 ad1 = AD_DPTR(DTYPEG(sptr));
5839 ad2 = AD_DPTR(dtype);
5840 ndim = AD_NUMDIM(ad1);
5841 if (ndim != AD_NUMDIM(ad2)) {
5842 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5843 goto dcl_shared_end;
5844 }
5845 for (i = 0; i < ndim; i++)
5846 if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) ||
5847 AD_UPBD(ad1, i) != AD_UPBD(ad2, i))
5848 break;
5849 if (i < ndim) {
5850 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5851 goto dcl_shared_end;
5852 }
5853 }
5854 error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
5855 break;
5856 default:
5857 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5858 goto dcl_shared_end;
5859 }
5860 DTY(dtype + 1) = DTYPEG(sptr);
5861 } else if (stype == ST_STRUCT) {
5862 if (IS_INTRINSIC(stype1)) {
5863 /* Changing intrinsic symbol to STRUCT */
5864 if ((sptr = newsym(sptr)) == 0)
5865 /* Symbol frozen as an intrinsic, ignore type decl */
5866 break;
5867 SST_SYMP(LHS, sptr);
5868 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5869 stype1 = ST_UNKNOWN;
5870 } else if (stype1 == ST_ARRAY && DCLDG(sptr) == 0) {
5871 /* this case is OK */
5872 } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT) {
5873 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
5874 break;
5875 }
5876 } else if ((scn.stmtyp == TK_COMMON || scn.stmtyp == TK_POINTER) &&
5877 IS_INTRINSIC(stype1)) {
5878 /* Changing intrinsic symbol to IDENT in COMMON/POINTER */
5879 if ((sptr = newsym(sptr)) == 0)
5880 /* Symbol frozen as an intrinsic, ignore in COMMON */
5881 break;
5882 SST_SYMP(LHS, sptr);
5883 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5884 stype1 = ST_UNKNOWN;
5885 dtype = DTYPEG(sptr);
5886 } else if (IN_MODULE_SPEC && !sem.interface && IS_INTRINSIC(stype1)) {
5887 /* Changing intrinsic symbol to IDENT in module specification */
5888 if ((sptr = newsym(sptr)) == 0)
5889 /* Symbol frozen as an intrinsic, ignore in COMMON */
5890 break;
5891 SST_SYMP(LHS, sptr);
5892 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
5893 stype1 = ST_UNKNOWN;
5894 dtype = DTYPEG(sptr);
5895 }
5896 /*
5897 * The symbol's stype and data type can only be changed if
5898 * it is new or if the type is changing from an identifier or
5899 * structure to an array. The latter can occur because of the
5900 * separation of type/record declarations from DIMENSION/COMMON
5901 * statements. If the symbol is a record, its stype can change
5902 * only if it's an identifier; note, that its dtype will be
5903 * set (and checked) by the semantic actions for record.
5904 */
5905 if (stype1 == ST_UNKNOWN ||
5906 (stype == ST_ARRAY &&
5907 (stype1 == ST_IDENT || stype1 == ST_VAR || stype1 == ST_STRUCT))) {
5908 STYPEP(sptr, stype);
5909 DTYPEP(sptr, dtype);
5910 if (DTY(dtype) == TY_ARRAY) {
5911 int d;
5912 d = DTY(dtype + 1);
5913 if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
5914 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5915 }
5916 }
5917 if (stype == ST_ARRAY) {
5918 if (POINTERG(sptr)) {
5919 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
5920 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5921 if (SCG(sptr) != SC_DUMMY)
5922 ALLOCP(sptr, 1);
5923 if (!F90POINTERG(sptr)) {
5926 }
5927 } else if (AD_ASSUMSZ(ad)) {
5928 if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
5929 SCG(sptr) != SC_BASED)
5930 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5931 ASUMSZP(sptr, 1);
5932 SEQP(sptr, 1);
5933 }
5934 if (AD_ADJARR(ad)) {
5935 ADJARRP(sptr, 1);
5936 /*
5937 * mark the adjustable array if the declaration
5938 * occurs after an ENTRY statement.
5939 */
5940 if (entry_seen)
5941 AFTENTP(sptr, 1);
5942 } else if (!POINTERG(sptr) && AD_DEFER(ad)) {
5943 if (SCG(sptr) == SC_CMBLK)
5944 error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr));
5945 if (SCG(sptr) == SC_DUMMY) {
5947 ASSUMSHPP(sptr, 1);
5948 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
5949 SDSCS1P(sptr, 1);
5950 } else {
5951 if (AD_ASSUMSHP(ad)) {
5952 /* this is an error if it isn't a dummy; the
5953 * declaration could occur before its entry, so
5954 * the check needs to be performed in semfin.
5955 */
5956 ASSUMSHPP(sptr, 1);
5957 if (!XBIT(54, 2))
5958 SDSCS1P(sptr, 1);
5959 }
5960 ALLOCP(sptr, 1);
5962 }
5963 }
5964 }
5965 } else if (sem.gdtype != -1 && DTY(sem.gdtype) == TY_DERIVED) {
5966 if (stype1 == ST_ENTRY) {
5967 if (FVALG(sptr)) {
5968/* should not reach this point */
5969#if DEBUG
5970 interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
5971#endif
5972 sptr = FVALG(sptr);
5973 } else {
5974 error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
5975 sptr = insert_sym(sptr);
5976 }
5977 }
5978 if (stype == ST_ARRAY && RESULTG(sptr)) {
5979 DTYPEP(sptr, dtype);
5980 if (POINTERG(sptr)) {
5981 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
5982 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
5983 } else if (AD_ASSUMSZ(ad)) {
5984 ASUMSZP(sptr, 1);
5985 SEQP(sptr, 1);
5986 } else if (AD_ADJARR(ad))
5987 ADJARRP(sptr, 1);
5988 else if (AD_DEFER(ad)) {
5990 ASSUMSHPP(sptr, 1);
5991 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
5992 SDSCS1P(sptr, 1);
5993 AD_ASSUMSHP(ad) = 1;
5994 }
5996 }
5997 } else if (stype == ST_STRUCT && stype1 == ST_IDENT)
5998 STYPEP(sptr, ST_STRUCT);
5999 else if (stype == ST_ARRAY) {
6000 if (stype1 == ST_ENTRY) {
6001 if (FVALG(sptr)) {
6002/* should not reach this point */
6003#if DEBUG
6004 interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
6005#endif
6006 sptr = FVALG(sptr);
6007 } else {
6008 error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
6009 sptr = insert_sym(sptr);
6010 }
6011 }
6012 if (RESULTG(sptr)) {
6013 DTYPEP(sptr, dtype);
6014 if (POINTERG(sptr)) {
6015 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
6016 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6017 } else if (AD_ASSUMSZ(ad)) {
6018 ASUMSZP(sptr, 1);
6019 SEQP(sptr, 1);
6020 } else if (AD_ADJARR(ad))
6021 ADJARRP(sptr, 1);
6022 else if (AD_DEFER(ad)) {
6024 ASSUMSHPP(sptr, 1);
6025 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
6026 SDSCS1P(sptr, 1);
6027 AD_ASSUMSHP(ad) = 1;
6028 }
6030 }
6031 }
6032 }
6033 dcl_shared_end:
6034 if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
6035 RESULTG(sptr)) {
6036 /* set the type for the entry point as well */
6038 }
6039 break;
6040
6041 /* ------------------------------------------------------------------ */
6042 /*
6043 * <dim beg> ::= (
6044 */
6045 case DIM_BEG1:
6046 sem.in_dim = 1;
6047 sem.arrdim.ndim = 0;
6048 sem.arrdim.ndefer = 0;
6049 break;
6050
6051 /* ------------------------------------------------------------------ */
6052 /*
6053 * <dimension list> ::= <dim list>
6054 */
6055 case DIMENSION_LIST1:
6056
6057 sem.in_dim = 0;
6058 dtype = mk_arrdsc(); /* semutil2.c */
6060 break;
6061 /* ------------------------------------------------------------------ */
6062 /*
6063 * <dim list> ::= <dim list> , <dim spec> |
6064 */
6065 case DIM_LIST1:
6066 break;
6067 /*
6068 * <dim list> ::= <dim spec>
6069 */
6070 case DIM_LIST2:
6071 break;
6072
6073 /* ------------------------------------------------------------------ */
6074 /*
6075 * <dim spec> ::= <explicit shape> |
6076 */
6077 case DIM_SPEC1:
6078 break;
6079 /*
6080 * <dim spec> ::= <expression> : * |
6081 */
6082 case DIM_SPEC2:
6083 rhstop = 3;
6084 SST_IDP(RHS(3), S_STAR);
6085 goto dim_spec;
6086 /*
6087 * <dim spec> ::= *
6088 */
6089 case DIM_SPEC3:
6090 rhstop = 1;
6091 SST_IDP(RHS(1), S_STAR);
6092 dim_spec:
6093 if (sem.arrdim.ndim >= MAXDIMS) {
6094 error(47, 3, gbl.lineno, CNULL, CNULL);
6095 break;
6096 }
6097
6098 /* check upper bound expression */
6099 constarraysize = 1;
6100 arraysize = 0;
6101
6102 constant_lvalue(RHS(rhstop));
6103 if (SST_IDG(RHS(rhstop)) == S_CONST) {
6104 sem.bounds[sem.arrdim.ndim].uptype = S_CONST;
6105 if (flg.standard) {
6106 int uptyp;
6107 uptyp = SST_DTYPEG(RHS(rhstop));
6108 if (!DT_ISINT(uptyp)) {
6109 error(170, 2, gbl.lineno, "array upper bound", "is not integer");
6110 }
6111 }
6112 arraysize = sem.bounds[sem.arrdim.ndim].upb =
6113 chkcon_to_isz(RHS(rhstop), FALSE);
6114 sem.bounds[sem.arrdim.ndim].upast = mk_bnd_int(SST_ASTG(RHS(rhstop)));
6115 } else if (SST_IDG(RHS(rhstop)) == S_STAR) {
6116 constarraysize = 0;
6117 sem.bounds[sem.arrdim.ndim].uptype = S_STAR;
6118 sem.bounds[sem.arrdim.ndim].upb = 0;
6119 sem.bounds[sem.arrdim.ndim].upast = 0;
6120 SST_LSYMP(RHS(rhstop), 0);
6121 SST_DTYPEP(RHS(rhstop), DT_INT);
6122 } else {
6123 constarraysize = 0;
6124 sem.bounds[sem.arrdim.ndim].uptype = S_EXPR;
6125 sem.bounds[sem.arrdim.ndim].upb =
6126 chk_arr_extent(RHS(rhstop), "array upper bound");
6127 ast = SST_ASTG(RHS(rhstop));
6128 if (A_ALIASG(ast)) {
6129 ast = mk_bnd_int(A_ALIASG(ast));
6130 sem.bounds[sem.arrdim.ndim].uptype = S_CONST;
6131 sem.bounds[sem.arrdim.ndim].upb = get_isz_cval(A_SPTRG(ast));
6132 } else {
6133 /* When we have an AST with A_CONV, we want to skip the type
6134 conversion AST in order to process the real intrinsic-call AST.*/
6135 if (A_TYPEG(ast) == A_CONV) {
6136 if (A_LOPG(ast) && A_TYPEG(A_LOPG(ast)) == A_INTR)
6137 ast = A_LOPG(ast);
6138 }
6139 if (*astb.atypes[A_TYPEG(ast)] == 'i' &&
6140 DT_ISINT(A_DTYPEG(ast)) && ast_isparam(ast)) {
6141 INT conval;
6142 ACL *acl = construct_acl_from_ast(ast, A_DTYPEG(ast), 0);
6143 if (acl) {
6144 acl = eval_init_expr(acl);
6145 conval = cngcon(acl->conval, acl->dtype, A_DTYPEG(ast));
6146 ast = mk_cval1(conval, (int)A_DTYPEG(ast));
6147 SST_IDP(RHS(1), S_CONST);
6148 SST_LSYMP(RHS(1), 0);
6149 SST_ASTP(RHS(1), ast);
6150 SST_ACLP(RHS(1), 0);
6151 if (DT_ISWORD(A_DTYPEG(ast)))
6152 SST_SYMP(RHS(1), CONVAL2G(A_SPTRG(ast)));
6153 else
6154 SST_SYMP(RHS(1), A_SPTRG(ast));
6155 }
6156 }
6157 }
6158 sem.bounds[sem.arrdim.ndim].upast = ast;
6159 }
6160
6161 /* check lower bound expression */
6162
6163 if (rhstop == 1) { /* set default lower bound */
6164 sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6165 sem.bounds[sem.arrdim.ndim].lowb = 1;
6166 sem.bounds[sem.arrdim.ndim].lwast = 0;
6167 } else {
6168 constant_lvalue(RHS(1));
6169 if (SST_IDG(RHS(1)) == S_CONST) {
6170 sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6171 if (flg.standard) {
6172 int lowtyp;
6173 lowtyp = SST_DTYPEG(RHS(1));
6174 if (!DT_ISINT(lowtyp)) {
6175 error(170, 2, gbl.lineno, "array lower bound", "is not integer");
6176 }
6177 }
6178 sem.bounds[sem.arrdim.ndim].lowb = chkcon_to_isz(RHS(1), FALSE);
6179 if (constarraysize)
6180 arraysize -= (sem.bounds[sem.arrdim.ndim].lowb - 1);
6181 sem.bounds[sem.arrdim.ndim].lwast = mk_bnd_int(SST_ASTG(RHS(1)));
6182 } else {
6183 constarraysize = 0;
6184 sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR;
6185 sem.bounds[sem.arrdim.ndim].lowb =
6186 chk_arr_extent(RHS(1), "array lower bound");
6187 ast = SST_ASTG(RHS(1));
6188 if (A_ALIASG(ast)) {
6189 ast = mk_bnd_int(A_ALIASG(ast));
6190 sem.bounds[sem.arrdim.ndim].lowtype = S_CONST;
6191 sem.bounds[sem.arrdim.ndim].lowb = get_isz_cval(A_SPTRG(ast));
6192 }
6193 sem.bounds[sem.arrdim.ndim].lwast = ast;
6194 }
6195 }
6196 if (constarraysize && arraysize < 0) {
6197 error(435, 2, gbl.lineno, "", CNULL);
6198 if (arraysize < 0) {
6199 /*
6200 * fix the upper bound to be lowb-1 so that the extent
6201 * evaluates to 0 so that the relatively new error #219,
6202 * 'Array too large' produced by dtypeutl.c:size_of_sym()
6203 * is avoided.
6204 */
6205 sem.bounds[sem.arrdim.ndim].upb = sem.bounds[sem.arrdim.ndim].lowb - 1;
6206 sem.bounds[sem.arrdim.ndim].upast =
6208 }
6209 }
6210 sem.arrdim.ndim++;
6211 break;
6212 /*
6213 * <dim spec> ::= : |
6214 */
6215 case DIM_SPEC4:
6216 if (sem.arrdim.ndim >= MAXDIMS) {
6217 error(47, 3, gbl.lineno, CNULL, CNULL);
6218 break;
6219 }
6220 sem.bounds[sem.arrdim.ndim].lowtype = 0;
6221 sem.arrdim.ndim++;
6222 sem.arrdim.ndefer++;
6223 break;
6224 /*
6225 * <dim spec> ::= <expression> : |
6226 */
6227 case DIM_SPEC5:
6228 if (sem.arrdim.ndim >= MAXDIMS) {
6229 error(47, 3, gbl.lineno, CNULL, CNULL);
6230 break;
6231 }
6232 sem.bounds[sem.arrdim.ndim].lowtype = S_EXPR;
6234 sem.bounds[sem.arrdim.ndim].lwast = SST_ASTG(RHS(1));
6235 sem.arrdim.ndim++;
6236 sem.arrdim.ndefer++;
6237 break;
6238 /*
6239 * <dim spec> ::= ..
6240 */
6241 case DIM_SPEC6:
6242 sem.arrdim.ndim++;
6243 sem.arrdim.ndefer++;
6244 sem.arrdim.assumedrank = TRUE;
6245 break;
6246
6247 /* ------------------------------------------------------------------ */
6248 /*
6249 * <explicit shape> ::= <expression> : <expression> |
6250 */
6251 case EXPLICIT_SHAPE1:
6252 rhstop = 3;
6253 goto dim_spec;
6254 /*
6255 * <explicit shape> ::= <expression>
6256 */
6257 case EXPLICIT_SHAPE2:
6258 rhstop = 1;
6259 goto dim_spec;
6260
6261 /* ------------------------------------------------------------------ */
6262 /*
6263 * <implicit type> ::= <implicit list> |
6264 */
6265 case IMPLICIT_TYPE1:
6266 break;
6267 /*
6268 * <implicit type> ::= NONE
6269 */
6270 case IMPLICIT_TYPE2:
6272 errwarn(55);
6274 error(70, 3, gbl.lineno, ": implicit none", CNULL);
6275 else
6278 if (sem.interface == 0) {
6279 ast_implicit(0, 0, 0);
6280 if (IN_MODULE_SPEC)
6281 mod_implicit(0, 0, 0);
6282 }
6283 break;
6284
6285 /* ------------------------------------------------------------------ */
6286 /*
6287 * <implicit list> ::= <implicit list> , <data type> <implp> <range list>
6288 * ) |
6289 */
6290 case IMPLICIT_LIST1:
6291 /*
6292 * <implicit list> ::= <data type> <implp> <range list> )
6293 */
6294 case IMPLICIT_LIST2:
6296 errwarn(56);
6298 break;
6299
6300 /* ------------------------------------------------------------------ */
6301 /*
6302 * <range list> ::= <range list> , <range> |
6303 */
6304 case RANGE_LIST1:
6305 rhstop = 3;
6306 goto range_list;
6307 /*
6308 * <range list> ::= <range>
6309 */
6310 case RANGE_LIST2:
6311 rhstop = 1;
6312 range_list:
6313 begin = SST_RNG1G(RHS(rhstop));
6314 end = SST_RNG2G(RHS(rhstop));
6315 if (begin > end) {
6316 errwarn(36);
6317 end = begin;
6318 }
6319 if (flg.standard && (begin == '$' || begin == '_' || end == 0))
6320 errwarn(175);
6321 newimplicit(begin, end, sem.gdtype);
6322 if (sem.interface == 0) {
6323 ast_implicit(begin, end, sem.gdtype);
6324 if (IN_MODULE_SPEC)
6325 mod_implicit(begin, end, sem.gdtype);
6326 }
6327
6328 /* adjust dtype of function and dummy arguments if necessary */
6329
6330 for (sptr = gbl.currsub; sptr && sptr != NOSYM; sptr = SYMLKG(sptr)) {
6331 if (gbl.rutype == RU_FUNC) {
6332 if (FVALG(sptr) && !DCLDG(FVALG(sptr))) {
6333 setimplicit(FVALG(sptr));
6334 copy_type_to_entry(FVALG(sptr));
6335 }
6336 }
6337
6338 count = PARAMCTG(sptr);
6339 i = DPDSCG(sptr);
6340 while (count--) {
6341 sptr2 = *(aux.dpdsc_base + i + count);
6342 if (!DCLDG(sptr2))
6343 setimplicit(sptr2);
6344 }
6345 }
6346 break;
6347
6348 /* ------------------------------------------------------------------ */
6349 /*
6350 * <range> ::= <letter> - <letter> |
6351 */
6352 case RANGE1:
6353 begin = SST_RNG1G(RHS(1));
6354 end = SST_RNG1G(RHS(3));
6355 if (begin == '$' || begin == '_' || end == '$' || end == '_') {
6356 /* cause an error and no action at the next production up */
6357 end = 0;
6358 }
6359 SST_RNG2P(LHS, end);
6360 break;
6361 /*
6362 * <range> ::= <letter>
6363 */
6364 case RANGE2:
6365 SST_RNG2P(LHS, SST_RNG1G(RHS(1)));
6366 break;
6367
6368 /* ------------------------------------------------------------------ */
6369 /*
6370 * <common list> ::= <common list> <com dcl> |
6371 */
6372 case COMMON_LIST1:
6373 break;
6374 /*
6375 * <common list> ::= <init com dcl>
6376 */
6377 case COMMON_LIST2:
6378 break;
6379
6380 /* ------------------------------------------------------------------ */
6381 /*
6382 * <init com dcl> ::= <dcl id list> |
6383 */
6384 case INIT_COM_DCL1:
6385 /*
6386 * <init com dcl> ::= <dcl id list> , |
6387 */
6388 case INIT_COM_DCL2:
6389 rhsptr = 1;
6390 goto blank_common;
6391 /*
6392 * <init com dcl> ::= <com dcl>
6393 */
6394 case INIT_COM_DCL3:
6395 break;
6396
6397 /* ------------------------------------------------------------------ */
6398 /*
6399 * <com dcl> ::= '//' <dcl id list> <optional comma> |
6400 */
6401 case COM_DCL1:
6402 rhsptr = 2;
6403 goto blank_common;
6404 /*
6405 * <com dcl> ::= / / <dcl id list> <optional comma> |
6406 */
6407 case COM_DCL2:
6408 rhsptr = 3;
6409 goto blank_common;
6410 blank_common:
6411 if (ignore_common_decl()) {
6412 break;
6413 }
6414 sptr = getsymbol("_BLNK_");
6415 sptr = refsym_inscope(sptr, OC_CMBLK);
6416 if (flg.xref)
6417 xrefput(sptr, 'd');
6418 if (STYPEG(sptr) == ST_UNKNOWN) {
6419 STYPEP(sptr, ST_CMBLK);
6420 SCOPEP(sptr, stb.curr_scope);
6421 SAVEP(sptr, 1);
6422 BLANKCP(sptr, 1);
6423 }
6424 goto com_dcl;
6425 /*
6426 * <com dcl> ::= <common> <dcl id list> <optional comma>
6427 */
6428 case COM_DCL3:
6429 if (ignore_common_decl()) {
6430 break;
6431 }
6432 rhsptr = 2;
6433 sptr = SST_SYMG(RHS(1));
6434 com_dcl:
6435 if (CMEMFG(sptr) == 0) {
6436 /* first definition of this common block */
6437 {
6438 SYMLKP(sptr, gbl.cmblks); /* link into list of common blocks */
6439 gbl.cmblks = sptr;
6440 }
6441 i = 0;
6442 CMEMFP(sptr, NOSYM);
6443 CMEMLP(sptr, NOSYM);
6444 } else
6445 i = CMEMLG(sptr); /* last element of common block so far */
6446
6447 /* loop thru dcl id list linking together symbol table entries */
6448 for (itemp = SST_BEGG(RHS(rhsptr)); itemp != ITEM_END;
6449 itemp = itemp->next) {
6450 sptr2 = itemp->t.sptr;
6451 stype = STYPEG(sptr2);
6452 if (IS_INTRINSIC(stype)) {
6453 /*
6454 * an intrinsic which can be changed due to its appearance in a
6455 * COMMON statement has already been processed in dcl_shared.
6456 * Getting here implies that the intrinsic is frozen, and
6457 * therefore, it will be ignored in the COMMON stmt.
6458 */
6459 error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6460 break;
6461 } else if (stype != ST_UNKNOWN && stype != ST_IDENT && stype != ST_VAR &&
6462 stype != ST_ARRAY && stype != ST_STRUCT &&
6463 (!POINTERG(sptr2))) {
6464 error(40, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6465 reinit_sym(sptr2);
6466 STYPEP(sptr2, ST_VAR);
6467 DTYPEP(sptr2, DT_INT);
6468 SCP(sptr2, SC_LOCAL);
6469 }
6470 if (SCG(sptr2) == SC_CMBLK || SCG(sptr2) == SC_DUMMY)
6471 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr2));
6472 else if (stype == ST_ARRAY && (ASUMSZG(sptr2) || ADJARRG(sptr2)))
6473 error(50, 3, gbl.lineno, SYMNAME(sptr2), CNULL);
6474 else if (SAVEG(sptr2)) {
6475 error(39, 2, gbl.lineno, SYMNAME(sptr2), " and a COMMON statement");
6476 SAVEP(sptr2, 0);
6477 } else {
6478 SCP(sptr2, SC_CMBLK);
6479 CMBLKP(sptr2, sptr);
6480 if (i == 0)
6481 CMEMFP(sptr, sptr2);
6482 else
6483 SYMLKP(i, sptr2);
6484 SYMLKP(sptr2, NOSYM);
6485 }
6486 i = sptr2;
6487 }
6488 CMEMLP(sptr, i); /* point to last element of common block */
6489 break;
6490
6491 /* ------------------------------------------------------------------ */
6492 /*
6493 * <common> ::= / <ident> /
6494 */
6495 case COMMON1:
6496 if (ignore_common_decl()) {
6497 SST_SYMP(LHS, 0);
6498 break;
6499 }
6500 sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_CMBLK);
6501 if (STYPEG(sptr) == ST_UNKNOWN) {
6502 STYPEP(sptr, ST_CMBLK);
6503 SCOPEP(sptr, stb.curr_scope);
6504 }
6505 SST_SYMP(LHS, sptr);
6506 break;
6507
6508 /* ------------------------------------------------------------------ */
6509 /*
6510 * <save list> ::= <save list> , <save id> |
6511 */
6512 case SAVE_LIST1:
6513 if (flg.xref)
6514 xrefput((int)SST_SYMG(RHS(3)), 'd');
6515 break;
6516 /*
6517 * <save list> ::= <save id>
6518 */
6519 case SAVE_LIST2:
6520 if (flg.xref)
6521 xrefput((int)SST_SYMG(RHS(1)), 'd');
6522 break;
6523
6524 /* ------------------------------------------------------------------ */
6525 /*
6526 * <save id> ::= <common>
6527 */
6528 case SAVE_ID1:
6529 sptr = SST_SYMG(RHS(1));
6530 if (sem.block_scope) {
6531 error(39, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6532 break;
6533 }
6534 SAVEP(sptr, 1);
6535 break;
6536 /*
6537 * <save id> ::= <ident>
6538 */
6539 case SAVE_ID2:
6541 stype = STYPEG(sptr);
6542
6543 /* <ident> must be a variable or an array; it cannot be a dummy
6544 * argument or common block member.
6545 */
6546 if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) {
6547 if (ASUMSZG(sptr))
6548 error(155, 3, gbl.lineno,
6549 "An assumed-size array cannot have the SAVE attribute -",
6550 SYMNAME(sptr));
6551 else if (SCG(sptr) == SC_DUMMY)
6552 error(155, 3, gbl.lineno,
6553 "An adjustable array cannot have the SAVE attribute -",
6554 SYMNAME(sptr));
6555 else
6556 error(155, 3, gbl.lineno,
6557 "An automatic array cannot have the SAVE attribute -",
6558 SYMNAME(sptr));
6559 } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
6560 SCG(sptr) == SC_BASED) &&
6561 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
6562 stype == ST_IDENT)) {
6563 sem.savloc = TRUE;
6564 SAVEP(sptr, 1);
6565 /* SCP(sptr, SC_LOCAL);
6566 * SAVE is now an attribute and may appear allocatable; the
6567 * appearance of a variable in a SAVE statement is no longer
6568 * sufficient to define the variable's storage class.
6569 */
6570 } else
6571 error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL);
6572 break;
6573
6574 /* ------------------------------------------------------------------ */
6575 /*
6576 * <ideqc list> ::= <ideqc list> , <ident> <init beg> <expression> |
6577 */
6578 case IDEQC_LIST1:
6579 rhstop = 5;
6580 goto common_ideqc;
6581 /*
6582 * <ideqc list> ::= <ident> <init beg> <expression>
6583 */
6584 case IDEQC_LIST2:
6585 rhstop = 3;
6586 common_ideqc:
6587 SST_IDP(RHS(rhstop - 2), S_IDENT);
6588 sptr = SST_SYMG(RHS(rhstop - 2));
6589
6590 fixup_param_vars(RHS(rhstop - 2), RHS(rhstop));
6591 if (DTY(DTYPEG(sptr)) == TY_ARRAY || DTY(DTYPEG(sptr)) == TY_DERIVED) {
6592 sptr1 = CONVAL1G(sptr);
6593
6594 construct_acl_for_sst(RHS(rhstop), DTYPEG(sptr1));
6595 if (!SST_ACLG(RHS(rhstop))) {
6596 goto end_ideqc;
6597 }
6599
6600 ast = mk_id(sptr1);
6601 SST_ASTP(RHS(rhstop - 2), ast);
6602 SST_DTYPEP(RHS(rhstop - 2), DTYPEG(sptr1));
6603 SST_SHAPEP(RHS(rhstop - 2), A_SHAPEG(ast));
6604 ivl = dinit_varref(RHS(rhstop - 2));
6605
6606 dinit(ivl, SST_ACLG(RHS(rhstop)));
6607 }
6608
6609 end_ideqc:
6610 if (flg.xref)
6611 xrefput(sptr, 'i');
6613 break;
6614
6615 /* ------------------------------------------------------------------ */
6616 /*
6617 * <init beg> ::= =
6618 */
6619 case INIT_BEG1:
6621 sem.equal_initializer = true;
6622 break;
6623
6624 /* ------------------------------------------------------------------ */
6625 /*
6626 * <vxeqc list> ::= <vxeqc list> , <ident> = <expression> |
6627 */
6628 case VXEQC_LIST1:
6629 rhstop = 5;
6630 goto common_vxeqc;
6631 /*
6632 * <vxeqc list> ::= <ident> = <expression>
6633 */
6634 case VXEQC_LIST2:
6635 rhstop = 3;
6636 common_vxeqc:
6637 sptr = declsym((int)SST_SYMG(RHS(rhstop - 2)), ST_PARAM, TRUE);
6638 dtype = SST_DTYPEG(RHS(rhstop));
6639 if (DCLDG(sptr) && dtype != DTYPEG(sptr))
6640 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6641
6642 if (SCG(sptr) != SC_NONE) {
6643 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6644 break;
6645 }
6646
6647 constant_lvalue(RHS(rhstop));
6648 if (SST_IDG(RHS(rhstop)) == S_CONST)
6649 conval = SST_CVALG(RHS(rhstop));
6650 else {
6651 errsev(87);
6652 dtype = DT_INT;
6653 conval = 1;
6654 }
6655 TYPDP(sptr, DCLDG(sptr)); /* appeared in a type statement */
6656 CONVAL2P(sptr, SST_ASTG(RHS(rhstop))); /* ast of <expression> */
6657 DTYPEP(sptr, dtype);
6658 DCLDP(sptr, TRUE);
6659 CONVAL1P(sptr, conval);
6660 VAXP(sptr, 1); /* vax-style parameter */
6661 if (sem.interface == 0)
6662 add_param(sptr);
6663 /* create an ast for the parameter; set the alias field of the ast
6664 * so that we don't have to set the alias field whenever the parameter
6665 * is referenced.
6666 */
6667 ast = mk_id(sptr);
6668 alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr));
6669 A_ALIASP(ast, alias);
6670 if (flg.xref)
6671 xrefput(sptr, 'i');
6672 break;
6673
6674 /* ------------------------------------------------------------------ */
6675 /*
6676 * <enums> ::= <enums> , <enum> |
6677 */
6678 case ENUMS1:
6679 break;
6680 /*
6681 * <enums> ::= <enum>
6682 */
6683 case ENUMS2:
6684 break;
6685
6686 /* ------------------------------------------------------------------ */
6687 /*
6688 * <enum> ::= <ident> = <expression> |
6689 */
6690 case ENUM1:
6691 rhstop = 3;
6692 constant_lvalue(RHS(rhstop));
6693 conval = chkcon(RHS(rhstop), DT_INT4, TRUE);
6694 goto common_enum;
6695 /*
6696 * <enum> ::= <ident>
6697 */
6698 case ENUM2:
6699 conval = next_enum;
6700 common_enum:
6701 dtype = DT_INT4;
6702 ast = mk_cval(conval, dtype);
6703 sptr = declsym(block_local_sym((int)SST_SYMG(RHS(1))), ST_PARAM, TRUE);
6704 if (DCLDG(sptr) || SCG(sptr) != SC_NONE) {
6705 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
6706 break;
6707 }
6708 TYPDP(sptr, DCLDG(sptr)); /* appeared in a type statement */
6709 CONVAL2P(sptr, ast); /* ast of <expression> */
6710 DTYPEP(sptr, dtype);
6711 DCLDP(sptr, TRUE);
6712 CONVAL1P(sptr, conval);
6713 ast = mk_id(sptr);
6714 alias = mk_cval1(CONVAL1G(sptr), (int)DTYPEG(sptr));
6715 A_ALIASP(ast, alias);
6716 next_enum = conval + 1;
6717 if (flg.xref)
6718 xrefput(sptr, 'i');
6719 break;
6720
6721 /* ------------------------------------------------------------------ */
6722 /*
6723 * <equiv groups> ::= <equiv groups> , <equiv group> |
6724 */
6725 case EQUIV_GROUPS1:
6726 break;
6727 /*
6728 * <equiv groups> ::= <equiv group>
6729 */
6730 case EQUIV_GROUPS2:
6731 break;
6732
6733 /* ------------------------------------------------------------------ */
6734 /*
6735 * <equiv group> ::= ( <equiv list> )
6736 */
6737 case EQUIV_GROUP1:
6738 /*
6739 * equivalence groups are linked together using the same field
6740 * used to link equivalence items within a single group.
6741 * A single equiv group is defined by the list beginning with an
6742 * EQVV item with a non-zero line number and ending with the item
6743 * preceding the next EQVV item with a non-zero line number (or
6744 * ending with the last item in the list). The remaining
6745 * members in the group have line number fields which are zero.
6746 */
6747 if (sem.interface) /* HACK - throw away if in an interface block*/
6748 break;
6749 EQV(SST_NMLENDG(RHS(2))).next = sem.eqvlist;
6750 sem.eqvlist = SST_NMLBEGG(RHS(2));
6751 break;
6752
6753 /* ------------------------------------------------------------------ */
6754 /*
6755 * <equiv list> ::= <equiv list> , <equiv var> |
6756 */
6757 case EQUIV_LIST1:
6758 rhstop = 3;
6759 goto common_equiv;
6760 /*
6761 * <equiv list> ::= <equiv var>
6762 */
6763 case EQUIV_LIST2:
6764 rhstop = 1;
6765 common_equiv:
6766 if (sem.interface) /* HACK - throw away if in an interface block*/
6767 break;
6768 evp = sem.eqv_avail;
6769 ++sem.eqv_avail;
6771 EQV(evp).sptr = SST_SYMG(RHS(rhstop));
6772 EQV(evp).subscripts = SST_SUBSCRIPTG(RHS(rhstop));
6773 EQV(evp).substring = SST_SUBSTRINGG(RHS(rhstop));
6774 EQV(evp).byte_offset = SST_OFFSETG(RHS(rhstop));
6775 EQV(evp).next = 0;
6776 /* SEQP(evp->sptr, 1); -- SEQ flag set in semfin.c */
6777 if (flg.xref)
6778 xrefput(EQV(evp).sptr, 'e');
6779 if (rhstop == 1) {
6780 EQV(evp).lineno = gbl.lineno;
6781 EQV(evp).is_first = 1;
6782 SST_NMLBEGP(LHS, evp);
6783 } else {
6784 EQV(evp).lineno = 0;
6785 EQV(evp).is_first = 0;
6786 EQV(SST_NMLENDG(RHS(1))).next = evp;
6787 }
6788 SST_NMLENDP(LHS, evp);
6789 break;
6790
6791 /* ------------------------------------------------------------------ */
6792 /*
6793 * <equiv var> ::= <ident> |
6794 */
6795 case EQUIV_VAR1:
6796 sptr = ref_ident_inscope((int)SST_SYMG(RHS(1)));
6797 SST_SYMP(LHS, sptr);
6798 SST_SUBSCRIPTP(LHS, 0); /* No subscripting */
6799 SST_OFFSETP(LHS, 0); /* No substringing */
6800 SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */
6801 break;
6802 /*
6803 * <equiv var> ::= <equiv var> ( <ssa list> ) |
6804 */
6805 case EQUIV_VAR2:
6806 /* Validate that the subscripts are constant expressions, and build
6807 * an item list of them in long term (until end of program) storage.
6808 */
6809 sptr = SST_SYMG(RHS(1));
6810 itemp = SST_BEGG(RHS(3));
6811 if (itemp->next == ITEM_END && SST_IDG(itemp->t.stkp) == S_TRIPLE) {
6812 if (SST_IDG(SST_E3G(itemp->t.stkp)) == S_NULL) {
6813 /* This is a possible form of a substring. Vector triplet
6814 * notation is illegal in any form.
6815 */
6816 if (SST_OFFSETG(RHS(1)))
6817 error(144, 3, gbl.lineno, "Ugly equivalence ", "1");
6818 if (SST_IDG(SST_E1G(itemp->t.stkp)) == S_NULL) {
6819 i = 1;
6820 SST_SUBSTRINGP(LHS, 0);
6821 } else {
6822 i = chkcon(SST_E1G(itemp->t.stkp), DT_INT4, TRUE);
6823 if (i <= 0) {
6824 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6825 i = 0;
6826 }
6828 }
6829 SST_OFFSETP(LHS, i);
6830 break;
6831 }
6832 }
6833
6834 if (SST_SUBSCRIPTG(RHS(1)) != 0) {
6835 error(144, 3, gbl.lineno, "Ugly equivalence 3", CNULL);
6836 break;
6837 }
6838 ss = 0;
6839 numss = 0;
6840 for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
6841 if (ss == 0) {
6842 numss = 1;
6844 sem.eqv_ss_avail += 2;
6846 sem.eqv_ss_size + 50);
6847 SST_SUBSCRIPTP(LHS, ss); /* Save begin of subscript list */
6848 EQV_NUMSS(ss) = numss;
6849 } else {
6850 ++sem.eqv_ss_avail;
6852 sem.eqv_ss_size + 50);
6853 ++numss;
6854 EQV_NUMSS(ss) = numss;
6855 }
6856 if (SST_IDG(itemp->t.stkp) == S_KEYWORD) {
6857 /* <ident> = <expr> is illegal just use <expr> part */
6858 errsev(79);
6859 SST_SUBSCRIPTP(LHS, 0);
6860 } else if (SST_IDG(itemp->t.stkp) == S_TRIPLE) {
6861 /* Legally this can only mean character substringing. Vector
6862 * triplet notation is not allowable in equivalencing.
6863 */
6864 error(155, 3, gbl.lineno,
6865 "Subscript triplet not allowed in EQUIVALENCE -", SYMNAME(sptr));
6866 SST_SUBSCRIPTP(LHS, 0);
6867 } else {
6868 (void)chkcon_to_isz(itemp->t.stkp, TRUE);
6869 EQV_SS(ss, numss - 1) = SST_ASTG(itemp->t.stkp);
6870 }
6871 }
6872 break;
6873 /*
6874 * <equiv var> ::= <equiv var> . <ident>
6875 */
6876 case EQUIV_VAR3:
6878 SST_SYMP(LHS, 0);
6879 SST_SUBSCRIPTP(LHS, 0); /* No subscripting */
6880 SST_OFFSETP(LHS, 0); /* No substringing */
6881 SST_SUBSTRINGP(LHS, 0); /* No substringing - ast */
6882 error(155, 3, gbl.lineno, "Member cannot be equivalenced -",
6883 SYMNAME(SST_SYMG(RHS(3))));
6884 break;
6885
6886 /* ------------------------------------------------------------------ */
6887 /*
6888 * <namelist groups> ::= <namelist groups> <namelist group> |
6889 */
6890 case NAMELIST_GROUPS1:
6891 break;
6892 /*
6893 * <namelist groups> ::= <namelist group>
6894 */
6895 case NAMELIST_GROUPS2:
6896 break;
6897
6898 /* ------------------------------------------------------------------ */
6899 /*
6900 * <namelist group> ::= / <ident> / <namelist list>
6901 */
6902 case NAMELIST_GROUP1:
6903 sptr = declref((int)SST_SYMG(RHS(2)), ST_NML, 'd');
6904 if (DCLDG(sptr))
6906 else {
6907 SYMLKP(sptr, sem.nml);
6908 sem.nml = sptr;
6909 CMEMFP(sptr, SST_NMLBEGG(RHS(4)));
6910 DCLDP(sptr, TRUE);
6911 /* create the array representing the namelist group */
6913 }
6914 CMEMLP(sptr, SST_NMLENDG(RHS(4)));
6915 break;
6916
6917 /* ------------------------------------------------------------------ */
6918 /*
6919 * <namelist list> ::= <namelist list> <namelist var> |
6920 */
6921 case NAMELIST_LIST1:
6922 rhstop = 2;
6923 goto nml_list;
6924 /*
6925 * <namelist list> ::= <namelist var>
6926 */
6927 case NAMELIST_LIST2:
6928 rhstop = 1;
6929 nml_list:
6930 i = aux.nml_avl++;
6932 NML_SPTR(i) = SST_SYMG(RHS(rhstop));
6933 NML_NEXT(i) = 0;
6934 NML_LINENO(i) = gbl.lineno;
6935 if (rhstop == 1) /* first item in the list */
6936 SST_NMLBEGP(LHS, i);
6937 else /* add item to the end of the list */
6938 NML_NEXT(SST_NMLENDG(RHS(1))) = i;
6939 SST_NMLENDP(LHS, i); /* item is now the end of the list */
6940 break;
6941
6942 /* ------------------------------------------------------------------ */
6943 /*
6944 * <namelist var> ::= <ident> <optional comma>
6945 */
6946 case NAMELIST_VAR1:
6947 sptr = ref_ident((int)SST_SYMG(RHS(1)));
6948 SST_SYMP(LHS, sptr);
6949 /* equivalence processing is done before the namelist processing;
6950 * this order is necessary to accomodate adding members to a
6951 * common block by equivalencing. For SC_LOCALs the namelist
6952 * processing switches the storage class to SC_STATIC; therefore,
6953 * the equivalence processor needs to know that a variable appeared
6954 * as a namelist item.
6955 */
6956 NMLP(sptr, 1);
6957 break;
6958
6959 /* ------------------------------------------------------------------ */
6960 /*
6961 * <struct begin1> ::= |
6962 */
6963 case STRUCT_BEGIN11:
6964 sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM);
6965 DTY(sem.stag_dtype + 3) = 0; /* no tag */
6966 if (sem.stsk_depth == 0)
6967 error(135, 2, gbl.lineno, CNULL, CNULL);
6968 break;
6969 /*
6970 * <struct begin1> ::= / <ident> /
6971 */
6972 case STRUCT_BEGIN12:
6973 sptr = declsym((int)SST_SYMG(RHS(2)), ST_STAG, TRUE);
6974 sem.stag_dtype = get_type(6, TY_STRUCT, NOSYM);
6975 DTYPEP(sptr, sem.stag_dtype); /* give tag its dtype */
6976 DTY(sem.stag_dtype + 3) = sptr; /* give dtype its tag */
6977 DTY(sem.stag_dtype + 5) = 0; /* ict pointer */
6978 NESTP(sptr, INSIDE_STRUCT); /* nested structure */
6979 /* NOTE: we don't set DCLD here; see ENDSTRUCTURE */
6980 break;
6981
6982 /* ------------------------------------------------------------------ */
6983 /*
6984 * <struct begin2> ::= |
6985 */
6986 case STRUCT_BEGIN21:
6988 break;
6989 /*
6990 * <struct begin2> ::= <field namelist>
6991 */
6992 case STRUCT_BEGIN22:
6993 break;
6994
6995 /* ------------------------------------------------------------------ */
6996 /*
6997 * <field namelist> ::= <field namelist> , <field name> |
6998 */
6999 case FIELD_NAMELIST1:
7000 SYMLKP(SST_SYMG(RHS(1)), SST_SYMG(RHS(3)));
7001 SST_SYMP(LHS, SST_SYMG(RHS(3)));
7002 break;
7003 /*
7004 * <field namelist> ::= <field name>
7005 */
7006 case FIELD_NAMELIST2:
7007 /* Save ptr to 1st field name in field namelist */
7008 SST_RNG2P(LHS, SST_SYMG(RHS(1)));
7009 break;
7010
7011 /* ------------------------------------------------------------------ */
7012 /*
7013 * <field name> ::= <ident> |
7014 */
7015 case FIELD_NAME1:
7017 goto field_name;
7018 /*
7019 * <field name> ::= <ident> <dim beg> <dimension list> )
7020 */
7021 case FIELD_NAME2:
7022 dtype = SST_DTYPEG(RHS(3));
7023 ad = AD_DPTR(dtype);
7024 if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))
7025 error(50, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
7026 field_name:
7027 stype = ST_MEMBER;
7028 sptr = SST_SYMG(RHS(1));
7029 if (STYPEG(sptr) != ST_UNKNOWN)
7031 SYMLKP(sptr, NOSYM);
7032 if (DTY(dtype) == TY_ARRAY)
7033 DTY(dtype + 1) = sem.stag_dtype;
7034 STYPEP(sptr, stype);
7035 DTYPEP(sptr, dtype);
7036 FNMLP(sptr, 1); /* declaration due to field name */
7037 break;
7038
7039 /* ------------------------------------------------------------------ */
7040 /*
7041 * <record list> ::= <record list> <record> |
7042 */
7043 case RECORD_LIST1:
7044 break;
7045 /*
7046 * <record list> ::= <record>
7047 */
7048 case RECORD_LIST2:
7049 break;
7050
7051 /* ------------------------------------------------------------------ */
7052 /*
7053 * <record> ::= / <struct name> / <record namelist>
7054 */
7055 case RECORD1:
7056 break;
7057
7058 /* ------------------------------------------------------------------ */
7059 /*
7060 * <struct name> ::= <ident>
7061 */
7062 case STRUCT_NAME1:
7063 /* Make sure sym ptr on stack is to a structure tag */
7064 SST_SYMP(LHS, (sptr = declref((int)SST_SYMG(RHS(1)), ST_STAG, 'r')));
7065 if (!DCLDG(sptr)) {
7066 error(139, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7067 dtype = get_type(6, TY_STRUCT, NOSYM);
7068 DTY(dtype + 2) = 1; /* size */
7069 DTY(dtype + 3) = sptr; /* tag */
7070 DTY(dtype + 5) = 0; /* ict pointer */
7071 DTYPEP(sptr, dtype);
7072 DCLDP(sptr, TRUE);
7073 }
7074 sem.stag_dtype = DTYPEG(sptr);
7075 break;
7076
7077 /* ------------------------------------------------------------------ */
7078 /*
7079 * <record namelist> ::= <record namelist> <record dcl> |
7080 */
7081 case RECORD_NAMELIST1:
7082 sptr = SST_SYMG(RHS(2));
7083 goto record_dcl;
7084 /*
7085 * <record namelist> ::= <record dcl>
7086 */
7087 case RECORD_NAMELIST2:
7088 sptr = SST_SYMG(RHS(1));
7089 record_dcl:
7091 inited = FALSE;
7092 ict1 = (ACL *)get_getitem_p(DTY(dtype + 5));
7093 if (ict1) {
7094 /* Need to build an initializer constant tree */
7095 ict = GET_ACL(15);
7096 *ict = *ict1;
7097 ict->sptr = sptr;
7098 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
7099 ict->repeatc = AD_NUMELM(AD_PTR(sptr));
7100 else
7101 ict->repeatc = astb.i1;
7102 if (INSIDE_STRUCT) {
7103 if (stsk->ict_end)
7104 stsk->ict_end->next = ict;
7105 else
7106 stsk->ict_beg = ict;
7107 stsk->ict_end = ict;
7108 } else if (SCG(sptr) != SC_DUMMY) {
7109 /*
7110 * NOTE: it's legal to use a STRUCTURE which contains
7111 * dinits to declare a dummy argument
7112 */
7113 dinit((VAR *)NULL, ict);
7114 }
7115 }
7116 goto common_typespecs;
7117
7118 /* ------------------------------------------------------------------ */
7119 /*
7120 * <record dcl> ::= <ident> <optional comma> |
7121 */
7122 case RECORD_DCL1:
7123 stype = ST_STRUCT;
7125 goto dcl_shared;
7126 /*
7127 * <record dcl> ::= <ident> <dim beg> <dimension list> ) <optional comma>
7128 */
7129 case RECORD_DCL2:
7130 stype = ST_ARRAY;
7131 dtype = SST_DTYPEG(RHS(3));
7132 ad = AD_DPTR(dtype);
7133 goto dcl_shared;
7134
7135 /* ------------------------------------------------------------------ */
7136 /*
7137 * <vol list> ::= <vol list> , <vol id> |
7138 */
7139 case VOL_LIST1:
7140 break;
7141 /*
7142 * <vol list> ::= <vol id>
7143 */
7144 case VOL_LIST2:
7145 break;
7146
7147 /* ------------------------------------------------------------------ */
7148 /*
7149 * <vol id> ::= <common> |
7150 */
7151 case VOL_ID1:
7152 sptr = SST_SYMG(RHS(1));
7153 VOLP(sptr, 1);
7154 break;
7155 /*
7156 * <vol id> ::= <ident>
7157 */
7158 case VOL_ID2:
7159 sptr = ref_ident_inscope((int)SST_SYMG(RHS(1)));
7161 !VOLG(sptr))
7162 error(1219, ERR_Severe, gbl.lineno,
7163 "VOLATILE statement in a BLOCK construct", CNULL);
7164 VOLP(sptr, true);
7165 break;
7166
7167 /* ------------------------------------------------------------------ */
7168 /*
7169 * <dinit list> ::= <dinit list> <optional comma> <dinit> |
7170 */
7171 case DINIT_LIST1:
7172 break;
7173 /*
7174 * <dinit list> ::= <dinit>
7175 */
7176 case DINIT_LIST2:
7177 break;
7178
7179 /* ------------------------------------------------------------------ */
7180 /*
7181 * <dinit> ::= <dinit var list> / <dinit const list> /
7182 */
7183 case DINIT1:
7184 /* call dinit to write data initialization records */
7185 if (!sem.dinit_error) {
7186 SST_CLBEGP(RHS(3),
7188 dinit(SST_VLBEGG(RHS(1)), SST_CLBEGG(RHS(3)));
7189 }
7192 break;
7193
7194 /* ------------------------------------------------------------------ */
7195 /*
7196 * <dinit var list> ::= <dinit var list> , <dinit var> |
7197 */
7198 case DINIT_VAR_LIST1:
7199 /* append entry to end of dinit var list */
7200 ((SST_VLENDG(RHS(1))))->next = SST_VLBEGG(RHS(3));
7202 break;
7203 /*
7204 * <dinit var list> ::= <dinit var>
7205 */
7206 case DINIT_VAR_LIST2:
7207 break;
7208
7209 /* ------------------------------------------------------------------ */
7210 /*
7211 * <dinit var> ::= <dvar ref> |
7212 */
7213 case DINIT_VAR1:
7214 (void)mklvalue(RHS(1), 2); /* ILM pointer of var ref */
7215 dtype = SST_DTYPEG(RHS(1));
7216 {
7217 /* build an element for the dinit var list */
7218 ivl = dinit_varref(RHS(1));
7219 if (ivl == NULL) {
7220 /* an array section was initialized -- dinit_varref()
7221 * transforms this <data var> into an implied do or a nested
7222 * implied do.
7223 */
7224 break;
7225 }
7226 }
7228 if (ivl->u.varref.id == S_LVALUE && SCG(SST_LSYMG(RHS(1))) == SC_BASED) {
7229 error(116, 3, gbl.lineno, SYMNAME(SST_LSYMG(RHS(1))), "(DATA)");
7231 }
7232 SST_VLBEGP(LHS, SST_VLENDP(LHS, ivl));
7233 break;
7234 /*
7235 * <dinit var> ::= ( <dinit var list> , <ident> = <expression> ,
7236 * <expression> <e3> )
7237 */
7238 case DINIT_VAR2:
7239 (void)chk_scalartyp(RHS((9)), DT_INT, TRUE);
7240 /* build a doend element for the dinit var list */
7241 ivl = (VAR *)getitem(15, sizeof(VAR));
7242 SST_VLENDP(LHS, ivl);
7243 SST_VLENDG(RHS(2))->next = ivl;
7244 ivl->id = Doend;
7245 ivl->next = NULL;
7246
7247 /* Create the dostart element, link it to the doend element, and
7248 * link all in the order dostart, <dinit var list>, then doend
7249 */
7250 ivl->u.doend.dostart = (VAR *)getitem(15, sizeof(VAR));
7251 ivl = ivl->u.doend.dostart;
7252 ivl->id = Dostart;
7253 sptr = refsym((int)SST_SYMG(RHS(4)), OC_OTHER);
7254 if (!DCLDG(sptr))
7255 IGNOREP(sptr, TRUE);
7256 SST_SYMP(RHS(4), sptr);
7257 (void)chktyp(RHS(4), DT_INT, TRUE);
7258 ivl->u.dostart.indvar = SST_ASTG(RHS(4));
7260 ivl->u.dostart.lowbd = SST_ASTG(RHS(6));
7262 ivl->u.dostart.upbd = SST_ASTG(RHS(8));
7263 ivl->u.dostart.step = SST_ASTG(RHS(9));
7264 ivl->next = SST_VLBEGG(RHS(2));
7265 SST_VLBEGP(LHS, ivl);
7266 break;
7267
7268 /* ------------------------------------------------------------------ */
7269 /*
7270 * <e3> ::= |
7271 */
7272 case E31:
7274 SST_CVALP(LHS, 1);
7276 SST_ASTP(LHS, 0);
7277 break;
7278 /*
7279 * <e3> ::= , <expression>
7280 */
7281 case E32:
7282 *LHS = *RHS(2);
7283 break;
7284
7285 /* ------------------------------------------------------------------ */
7286 /*
7287 * <dinit const list> ::= <dinit const list> , <data item> |
7288 */
7289 case DINIT_CONST_LIST1:
7290 if (SST_CLBEGG(RHS(3)) != NULL) {
7291 SST_CLENDG(RHS(1))->next = SST_CLBEGG(RHS(3));
7293 }
7294 break;
7295 /*
7296 * <dinit const list> ::= <data item>
7297 */
7298 case DINIT_CONST_LIST2:
7299 break;
7300
7301 /* ------------------------------------------------------------------ */
7302 /*
7303 * <data item> ::= <data constant> |
7304 */
7305 case DATA_ITEM1:
7306 conval = 1; /* default repeat count */
7307 ast = 0;
7308 goto common_data_item;
7309 /*
7310 * <data item> ::= <data rpt> * <data constant>
7311 */
7312 case DATA_ITEM2:
7313 ast = SST_ASTG(RHS(1));
7314 conval = SST_CVALG(RHS(1));
7315 *RHS(1) = *RHS(3);
7316 common_data_item:
7317 /*
7318 * Check for too many constant initializers here! Why here and not in
7319 * dinit? Because for structures and type decl stmts we want the error
7320 * flagged on the structure stmt not the record stmt which may occur
7321 * many times and much later.
7322 */
7323 if (!sem.dinit_data) { /* Don't do this if in DATA stmt */
7324 if (sem.dinit_count < conval) {
7325 if (sem.dinit_count >= 0)
7326 errsev(67);
7327 if (sem.dinit_count <= 0) { /* Error already handled */
7329 break;
7330 }
7331 conval = sem.dinit_count; /* Put out as many as possible */
7332 sem.dinit_count = -1; /* Prevent further error msgs */
7333 }
7334 sem.dinit_count -= conval;
7335 }
7336 if (SST_IDG(RHS(1)) == S_SCONST) {
7338 if (!ict) {
7339 break;
7340 }
7341 ict->repeatc = ast;
7342 SST_CLBEGP(LHS, SST_CLENDP(LHS, ict));
7343 break;
7344 }
7345
7346 /* allocate and init an Initializer Constant Tree entry */
7347 ict = GET_ACL(15);
7348 ict->id = AC_AST;
7349 ict->next = NULL;
7350 ict->subc = NULL;
7351 ict->u1.ast = SST_ASTG(RHS(1));
7352 ict->repeatc = ast;
7353 ict->sptr = 0;
7354 ict->dtype = SST_DTYPEG(RHS(1));
7355 SST_CLBEGP(LHS, SST_CLENDP(LHS, ict));
7356 break;
7357
7358 /* ------------------------------------------------------------------ */
7359 /*
7360 * <data rpt> ::= <integer> |
7361 */
7362 case DATA_RPT1:
7363 conval = SST_CVALG(RHS(1));
7364 ast = mk_cval(SST_CVALG(RHS(1)), DT_INT4);
7365 goto common_rpt;
7366 /*
7367 * <data rpt> ::= <int kind const> |
7368 */
7369 case DATA_RPT2:
7370 /* token value of <int kind const> is an ST_CONST entry */
7371 conval = get_int_cval(SST_CVALG(RHS(1)));
7372 ast = mk_cnst(SST_CVALG(RHS(1)));
7373 goto common_rpt;
7374 /*
7375 * <data rpt> ::= <ident constant>
7376 */
7377 case DATA_RPT3:
7378 dtype = SST_DTYPEG(RHS(1));
7379 if (dtype == DT_INT8 || dtype == DT_LOG8)
7380 conval = get_int_cval(SST_CVALG(RHS(1)));
7381 else
7382 conval = SST_CVALG(RHS(1));
7383 ast = SST_ASTG(RHS(1));
7384 common_rpt:
7385 if (conval < 0) {
7386 errsev(65);
7387 conval = 0;
7388 }
7389 SST_CVALP(LHS, conval);
7390 SST_ASTP(LHS, ast);
7391 break;
7392
7393 /* ------------------------------------------------------------------ */
7394 /*
7395 * <data constant> ::= <constant> |
7396 */
7397 case DATA_CONSTANT1:
7399 break;
7400 /*
7401 * <data constant> ::= <addop> <constant> |
7402 */
7403 case DATA_CONSTANT2:
7404 SST_IDP(RHS(2), S_CONST);
7405 goto addop_data_constant;
7406 /*
7407 * <data constant> ::= <ident constant> |
7408 */
7409 case DATA_CONSTANT3:
7410 break;
7411 /*
7412 * <data constant> ::= <addop> <ident constant> |
7413 */
7414 case DATA_CONSTANT4:
7415 addop_data_constant:
7416 opc = SST_OPTYPEG(RHS(1));
7417 *LHS = *RHS(2);
7418 if (opc == OP_SUB) {
7421 SST_ASTP(LHS, ast);
7423 }
7424 break;
7425 /*
7426 * <data constant> ::= <ident ssa> ( <ssa list> ) |
7427 */
7428 case DATA_CONSTANT5:
7429 sptr = SST_SYMG(RHS(1));
7430 dtype = SST_DTYPEG(RHS(1));
7431 if (sem.in_struct_constr) {
7432 /* create head AC_SCONST for element list */
7433 aclp = GET_ACL(15);
7434 aclp->id = AC_SCONST;
7435 aclp->next = NULL;
7436 aclp->subc = (ACL *)SST_BEGG(RHS(3));
7437 aclp->dtype = dtype = DTYPEG(sem.in_struct_constr);
7440 SST_ACLP(LHS, aclp);
7441 if (is_empty_typedef(dtype)) {
7442 error(155, 3, gbl.lineno, "Structure constructor specified"
7443 " for empty derived type",
7444 SYMNAME(sptr));
7445 } else
7447 SST_SYMP(LHS, sem.in_struct_constr); /* use tag as SYM */
7448 sem.in_struct_constr = SST_TMPG(LHS); /*restore old value */
7449 break;
7450 }
7451 sem.in_struct_constr = SST_TMPG(LHS); /* restore old value */
7452
7453 if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_NCHAR) {
7454 SST *sp;
7455
7456 itemp = SST_BEGG(RHS(3));
7457 sp = itemp->t.stkp;
7458 if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
7459 itemp->next != ITEM_END) {
7460 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7461 SST_DTYPEP(LHS, DT_NCHAR);
7462 val[0] = getstring(" ", 1);
7463 val[1] = 0;
7464 SST_CVALP(LHS, getcon(val, DT_NCHAR));
7466 SST_SHAPEP(LHS, 0);
7467 break;
7468 }
7470 SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */
7472 SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */
7473 SST_SHAPEP(LHS, 0);
7474 SST_ERRSYMP(LHS, sptr); /* save for error tracing */
7475 ch_substring(LHS, SST_E1G(sp), SST_E2G(sp));
7476 goto check_data_substring;
7477 }
7478 if (STYPEG(sptr) == ST_PARAM && DTY(dtype) == TY_CHAR) {
7479 SST *sp;
7480
7481 itemp = SST_BEGG(RHS(3));
7482 sp = itemp->t.stkp;
7483 if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
7484 itemp->next != ITEM_END) {
7485 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7486 SST_DTYPEP(LHS, DT_CHAR);
7487 SST_CVALP(LHS, getstring(" ", 1));
7489 SST_SHAPEP(LHS, 0);
7490 break;
7491 }
7493 SST_CVALP(LHS, CONVAL1G(sptr)); /* get constant sptr */
7495 SST_ASTP(LHS, CONVAL2G(sptr)); /* constant's ast */
7496 SST_SHAPEP(LHS, 0);
7497 SST_ERRSYMP(LHS, sptr); /* save for error tracing */
7498 ch_substring(LHS, SST_E1G(sp), SST_E2G(sp));
7499 goto check_data_substring;
7500 } else {
7501 errsev(87);
7503 }
7504 break;
7505 /*
7506 * <data constant> ::= <ident ssa> ( ) |
7507 */
7508 case DATA_CONSTANT6:
7509 if (STYPEG(SST_SYMG(RHS(1))) != ST_PD ||
7510 PDNUMG(SST_SYMG(RHS(1))) != PD_null) {
7511 dtype = SST_DTYPEG(RHS(1));
7513 /* Ignore empty struct constructor for an
7514 * empty typedef
7515 */
7517 break;
7518 }
7519 errsev(87);
7521 break;
7522 }
7523 SST_IDP(RHS(1), S_IDENT);
7524 (void)mkvarref(RHS(1), ITEM_END);
7525 break;
7526
7527 /*
7528 * <data constant> ::= <substring>
7529 */
7530 case DATA_CONSTANT7:
7531 dtype = SST_DTYPEG(RHS(1));
7532 check_data_substring:
7533 constant_lvalue(RHS(1));
7534 if (SST_IDG(RHS(1)) != S_CONST) {
7535 errsev(87);
7537 if (DTY(dtype) == TY_NCHAR) {
7538 SST_DTYPEP(LHS, DT_NCHAR);
7539 val[0] = getstring(" ", 1);
7540 val[1] = 0;
7541 SST_CVALP(LHS, getcon(val, DT_NCHAR));
7543 SST_SHAPEP(LHS, 0);
7544 break;
7545 }
7546 SST_DTYPEP(LHS, DT_CHAR);
7547 SST_CVALP(LHS, getstring(" ", 1));
7549 SST_SHAPEP(LHS, 0);
7550 }
7551 break;
7552 /*
7553 * <ident ssa> ::= <ident>
7554 */
7555 case IDENT_SSA1:
7556 sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
7557 dtype = DTYPEG(sptr);
7558 SST_SYMP(LHS, sptr);
7560 SST_TMPP(LHS, sem.in_struct_constr); /* save old value */
7561 /* set a flag for ssa list processing */
7562 if (STYPEG(sptr) == ST_TYPEDEF && DTY(dtype) == TY_DERIVED) {
7564 } else
7566 break;
7567
7568 /*
7569 * <ident constant> ::= <ident>
7570 */
7571 case IDENT_CONSTANT1:
7572 sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
7574 if (STYPEG(sptr) == ST_PARAM) {
7575 /* resolve constant */
7576 SST_DTYPEP(LHS, DTYPEG(sptr));
7577 SST_CVALP(LHS, CONVAL1G(sptr));
7578 ast = mk_id(sptr);
7579 if (!XBIT(49, 0x10)) /* preserve PARAMETER? */
7580 ast = A_ALIASG(ast);
7581 } else if (flg.standard)
7582 goto ident_constant_error;
7583 else {
7584 np = SYMNAME(sptr);
7585 if (*np == 't') {
7586 if (DTY(stb.user.dt_log) == TY_LOG8) {
7587 if (gbl.ftn_true == -1)
7588 val[0] = val[1] = -1;
7589 else {
7590 val[0] = 0;
7591 val[1] = 1;
7592 }
7593 SST_CVALP(LHS, getcon(val, DT_LOG8));
7595 } else {
7598 }
7600 } else if (*np == 'f') {
7601 if (DTY(stb.user.dt_log) == TY_LOG8) {
7602 val[0] = val[1] = 0;
7603 SST_CVALP(LHS, getcon(val, DT_LOG8));
7605 } else {
7608 }
7610 } else
7611 goto ident_constant_error;
7612 }
7613 SST_ASTP(LHS, ast);
7614 break;
7615 ident_constant_error:
7616 errsev(87);
7617 SST_CVALP(LHS, stb.i0);
7618 SST_DTYPEP(LHS, DT_INT4);
7619 ast = mk_id(sptr);
7621 break;
7622
7623 /* ------------------------------------------------------------------ */
7624 /*
7625 * <ptr list> ::= <ptr list> , <ptr assoc> |
7626 */
7627 case PTR_LIST1:
7628 break;
7629 /*
7630 * <ptr list> ::= <ptr assoc>
7631 */
7632 case PTR_LIST2:
7633 break;
7634
7635 /* ------------------------------------------------------------------ */
7636 /*
7637 * <ptr assoc> ::= ( <ident> , <dcl id> ) |
7638 */
7639 case PTR_ASSOC1:
7640 sptr = declsym((int)SST_SYMG(RHS(2)), ST_VAR, FALSE);
7641 if (flg.standard)
7642 error(171, 2, gbl.lineno, "- Cray POINTER statement", CNULL);
7643 if (XBIT(124, 0x10)) {
7644 /* -i8 */
7645 if (DCLDG(sptr) && DTYPEG(sptr) != DT_INT8)
7646 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7647 DTYPEP(sptr, DT_INT8);
7648 } else {
7649 if (DCLDG(sptr) && DTYPEG(sptr) != DT_PTR)
7650 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7651 DTYPEP(sptr, DT_PTR);
7652 }
7653 DCLDP(sptr, TRUE);
7654 PTRVP(sptr, 1);
7655 sptr1 = SST_SYMG(RHS(4));
7656 if (VOLG(sptr1) || SCG(sptr1) != SC_NONE) {
7657 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr1));
7658 break;
7659 }
7660 SCP(sptr1, SC_BASED);
7661 MIDNUMP(sptr1, sptr);
7662 if (SAVEG(sptr1))
7663 error(39, 2, gbl.lineno, SYMNAME(sptr1), CNULL);
7664 if (STYPEG(sptr1) == ST_ARRAY) {
7665 if (ADJARRG(sptr1) || RUNTIMEG(sptr1)) {
7666 if (entry_seen)
7667 AFTENTP(sptr1, 1);
7668 }
7669 }
7670 while (TRUE) {
7671 if (SCG(sptr) == SC_BASED) {
7672 if (sptr == sptr1) {
7673 error(155, 3, gbl.lineno, "Recursive POINTER declaration of",
7674 SYMNAME(sptr1));
7675 MIDNUMP(sptr1, 0);
7676 SCP(sptr1, SC_NONE);
7677 break;
7678 }
7679 sptr = MIDNUMG(sptr);
7680 } else
7681 break;
7682 }
7683 break;
7684 /*
7685 * <ptr assoc> ::= <alloc id>
7686 */
7687 case PTR_ASSOC2:
7688 break;
7689
7690 /* ------------------------------------------------------------------ */
7691 /*
7692 * <alloc id list> ::= <alloc id list> , <alloc id> |
7693 */
7694 case ALLOC_ID_LIST1:
7695 break;
7696 /*
7697 * <alloc id list> ::= <alloc id>
7698 */
7699 case ALLOC_ID_LIST2:
7700 break;
7701
7702 /* ------------------------------------------------------------------ */
7703 /*
7704 * <alloc id> ::= <ident> |
7705 */
7706 case ALLOC_ID1:
7707 sptr = SST_SYMG(RHS(1));
7708 sptr = create_var(sptr);
7709 SST_SYMP(LHS, sptr);
7710 if (STYPEG(sptr) == ST_UNKNOWN)
7711 STYPEP(sptr, ST_IDENT);
7712 stype1 = STYPEG(sptr);
7713 if (IS_INTRINSIC(stype1)) {
7714 /* Changing intrinsic symbol to ARRAY */
7715 if ((sptr = newsym(sptr)) == 0)
7716 /* Symbol frozen as an intrinsic, ignore type decl */
7717 break;
7718 SST_SYMP(LHS, sptr);
7719 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
7720 stype1 = ST_UNKNOWN;
7721 } else if (stype1 == ST_ENTRY) {
7722 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7723 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7724 break;
7725 }
7726 } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR &&
7727 stype1 != ST_ARRAY) {
7728 /* Add special handling for procedure pointers
7729 *
7730 * The only two ways we can get here is either through pointer or through
7731 * allocatable declaration. Pointer attribute can be applied to
7732 * procedures, but not allocatable attribute.
7733 */
7734 if ((scn.stmtyp != TK_POINTER) || (stype1 != ST_PROC)) {
7735 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7736 break;
7737 }
7738 }
7739
7740 if (scn.stmtyp == TK_POINTER) {
7741 POINTERP(sptr, TRUE);
7742 if (STYPEG(sptr) == ST_PROC) {
7743 LOGICAL declared;
7744 sptr = SST_SYMG(RHS(1));
7745 /* Save "declared" flag to preserve implicit types */
7746 declared = DCLDG(sptr);
7747 /* Generate proper procedure symbol */
7748 sptr = insert_sym(sptr);
7749 sptr = setup_procedure_sym(sptr, proc_interf_sptr, ET_B(ET_POINTER),
7750 entity_attr.access);
7751 SST_SYMP(RHS(1), sptr);
7752 /* Restore "declared" flag */
7753 DCLDP(sptr, declared);
7754 }
7755 if (sem.contiguous)
7756 CONTIGATTRP(sptr, 1);
7757 if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7758 F90POINTERP(sptr, TRUE);
7759 }
7760 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7761 dtype = DTYPEG(sptr);
7762 ad = AD_DPTR(dtype);
7763 if (SCG(sptr) != SC_DUMMY) {
7764 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
7765 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7766 ALLOCP(sptr, 1);
7767 } else {
7768 if (!AD_DEFER(ad))
7769 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7770 /* may have assumed the array was assumed-shape;
7771 * now we know better, it's an array pointer */
7772 ASSUMSHPP(sptr, 0);
7773 SDSCS1P(sptr, 0);
7774 AD_ASSUMSHP(ad) = 0;
7775 }
7776 if (!F90POINTERG(sptr)) {
7779 }
7780 }
7781 } else if ((stype1 != ST_ARRAY && stype1 != ST_IDENT
7782 /* Allow ST_IDENT here. It happens when an
7783 * ALLOCATABLE statement precedes the DIMENSION statement.
7784 * If the allocatable is still an ST_IDENT in semfin.c,
7785 * we'll call it an error at that time.
7786 */
7787 ) ||
7788 (!ALLOCG(sptr) && stype1 != ST_IDENT) || SCG(sptr) != SC_NONE)
7789 error(84, 3, gbl.lineno, SYMNAME(sptr),
7790 "- must be a deferred shape array");
7791 else
7792 ALLOCATTRP(sptr, 1);
7793
7794 if (RESULTG(sptr)) {
7795 /* set the type for the entry point as well */
7797 }
7798 break;
7799 /*
7800 * <alloc id> ::= <ident> <dim beg> <dimension list> )
7801 */
7802 case ALLOC_ID2:
7803 sptr = SST_SYMG(RHS(1));
7804 sptr = create_var(sptr);
7805 SST_SYMP(LHS, sptr);
7806 if (STYPEG(sptr) == ST_UNKNOWN)
7807 STYPEP(sptr, ST_IDENT);
7808 stype1 = STYPEG(sptr);
7809 if (IS_INTRINSIC(stype1)) {
7810 /* Changing intrinsic symbol to ARRAY */
7811 if ((sptr = newsym(sptr)) == 0)
7812 /* Symbol frozen as an intrinsic, ignore type decl */
7813 break;
7814 SST_SYMP(LHS, sptr);
7815 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
7816 stype1 = ST_UNKNOWN;
7817 } else if (stype1 == ST_ENTRY) {
7818 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
7819 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7820 break;
7821 }
7822 } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT && stype1 != ST_VAR) {
7823 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
7824 break;
7825 }
7826
7827 STYPEP(sptr, ST_ARRAY);
7828 dtype = SST_DTYPEG(RHS(3));
7829 ad = AD_DPTR(dtype);
7830 DTY(dtype + 1) = DTYPEG(sptr);
7831 DTYPEP(sptr, dtype);
7832 if (DTY(dtype) == TY_ARRAY) {
7833 int d;
7834 d = DTY(dtype + 1);
7835 if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
7836 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7837 }
7838 }
7839 if (scn.stmtyp == TK_POINTER) {
7840 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
7841 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
7842 if (SCG(sptr) != SC_DUMMY)
7843 ALLOCP(sptr, 1);
7844 POINTERP(sptr, TRUE);
7845 if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7846 F90POINTERP(sptr, TRUE);
7847 }
7848 if (SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
7851 }
7852 } else if (AD_DEFER(ad) == 0)
7853 error(84, 3, gbl.lineno, SYMNAME(sptr),
7854 "- must be a deferred shape array");
7855 else {
7856 ALLOCP(sptr, 1);
7857 ALLOCATTRP(sptr, 1);
7858 if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
7859 F90POINTERP(sptr, TRUE);
7860 }
7861 }
7862 if (RESULTG(sptr)) {
7863 /* set the type for the entry point as well */
7865 }
7866 break;
7867
7868 /* ------------------------------------------------------------------ */
7869 /*
7870 * <opt attr list> ::= |
7871 */
7872 case OPT_ATTR_LIST1:
7873 /*
7874 * <opt attr list> ::= , <attr list>
7875 */
7876 case OPT_ATTR_LIST2:
7878 break;
7879
7880 /* ------------------------------------------------------------------ */
7881 /*
7882 * <attr list> ::= <attr list> , <attr> |
7883 */
7884 case ATTR_LIST1:
7885 /* fall thru */
7886 /*
7887 * <attr list> ::= <attr>
7888 */
7889 case ATTR_LIST2:
7890 if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
7891 if (!(et_type == ET_DIMENSION || et_type == ET_POINTER
7892 || et_type == ET_ACCESS || et_type == ET_ALLOCATABLE ||
7893 et_type == ET_CONTIGUOUS || et_type == ET_KIND ||
7894 et_type == ET_LEN))
7895 error(134, 3, gbl.lineno, et[et_type].name,
7896 "for derived type component");
7897 }
7898 if (entity_attr.exist & ET_B(et_type))
7899 error(134, 3, gbl.lineno, "- duplicate", et[et_type].name);
7900 else if (entity_attr.exist & et[et_type].no)
7901 error(134, 3, gbl.lineno, "- conflict with", et[et_type].name);
7902 else {
7903 entity_attr.exist |= ET_B(et_type);
7904 }
7905 break;
7906
7907 /* ------------------------------------------------------------------ */
7908 /*
7909 * <attr> ::= PARAMETER |
7910 */
7911 case ATTR1:
7912 et_type = ET_PARAMETER;
7913 break;
7914 /*
7915 * <attr> ::= <access spec> |
7916 */
7917 case ATTR2:
7918 et_type = ET_ACCESS;
7919 break;
7920 /*
7921 * <attr> ::= ALLOCATABLE |
7922 */
7923 case ATTR3:
7924 et_type = ET_ALLOCATABLE;
7925 break;
7926 /*
7927 * <attr> ::= <dimattr> <dim beg> <dimension list> ) |
7928 */
7929 case ATTR4:
7930 et_type = ET_DIMENSION;
7931 entity_attr.dimension = SST_DTYPEG(RHS(3));
7932 /* save bounds information just in case the dimension attribute
7933 * is used more than once
7934 */
7935 BCOPY(entity_attr.bounds, sem.bounds, char, sizeof(sem.bounds));
7936 BCOPY(entity_attr.arrdim, &sem.arrdim, char, sizeof(sem.arrdim));
7937 break;
7938 /*
7939 * <attr> ::= EXTERNAL |
7940 */
7941 case ATTR5:
7942 et_type = ET_EXTERNAL;
7943 break;
7944 /*
7945 * <attr> ::= <intent> |
7946 */
7947 case ATTR6:
7948 et_type = ET_INTENT;
7949 break;
7950 /*
7951 * <attr> ::= INTRINSIC |
7952 */
7953 case ATTR7:
7954 et_type = ET_INTRINSIC;
7955 break;
7956 /*
7957 * <attr> ::= OPTIONAL |
7958 */
7959 case ATTR8:
7960 et_type = ET_OPTIONAL;
7961 break;
7962 /*
7963 * <attr> ::= POINTER |
7964 */
7965 case ATTR9:
7966 et_type = ET_POINTER;
7967 break;
7968 /*
7969 * <attr> ::= SAVE |
7970 */
7971 case ATTR10:
7972 et_type = ET_SAVE;
7973 break;
7974 /*
7975 * <attr> ::= TARGET |
7976 */
7977 case ATTR11:
7978 et_type = ET_TARGET;
7979 break;
7980 /*
7981 * <attr> ::= AUTOMATIC |
7982 */
7983 case ATTR12:
7984 et_type = ET_AUTOMATIC;
7985 break;
7986 /*
7987 * <attr> ::= STATIC |
7988 */
7989 case ATTR13:
7990 et_type = ET_STATIC;
7991 break;
7992 /*
7993 * <attr> ::= BIND <bind attr> |
7994 */
7995 case ATTR14:
7996 et_type = ET_BIND;
7997 break;
7998 /*
7999 * <attr> ::= VALUE |
8000 */
8001 case ATTR15:
8002 et_type = ET_VALUE;
8003 break;
8004 /*
8005 * <attr> ::= VOLATILE |
8006 */
8007 case ATTR16:
8008 et_type = ET_VOLATILE;
8009 break;
8010 /*
8011 * <attr> ::= DEVICE |
8012 */
8013 case ATTR17:
8014 if (cuda_enabled("device"))
8015 et_type = ET_DEVICE;
8016 else
8017 et_type = 0;
8018 break;
8019 /*
8020 * <attr> ::= PINNED |
8021 */
8022 case ATTR18:
8023 if (cuda_enabled("pinned"))
8024 et_type = ET_PINNED;
8025 else
8026 et_type = 0;
8027 break;
8028 /*
8029 * <attr> ::= SHARED |
8030 */
8031 case ATTR19:
8032 et_type = 0;
8033#ifdef CUDAG
8034 if (cuda_enabled("shared")) {
8035 if ((gbl.currsub && CUDAG(gbl.currsub) &&
8036 !(CUDAG(gbl.currsub) & CUDA_HOST)) ||
8037 (gbl.currmod && !gbl.currsub)) {
8038 /* device routine, or module declaration part */
8039 et_type = ET_SHARED;
8040 } else {
8041 error(134, 3, gbl.lineno, et[ET_SHARED].name,
8042 "not allowed in host subprograms");
8043 }
8044 }
8045#endif
8046 break;
8047 /*
8048 * <attr> ::= CONSTANT |
8049 */
8050 case ATTR20:
8051 et_type = 0;
8052#ifdef CUDAG
8053 if (cuda_enabled("constant")) {
8054 if ((gbl.currsub && CUDAG(gbl.currsub) &&
8055 !(CUDAG(gbl.currsub) & CUDA_HOST)) ||
8056 (gbl.currmod && !gbl.currsub)) {
8057 /* device routine, or module declaration part */
8058 et_type = ET_CONSTANT;
8059 } else {
8060 error(134, 3, gbl.lineno, et[ET_CONSTANT].name,
8061 "not allowed in host subprograms");
8062 }
8063 }
8064#endif
8065 break;
8066 /*
8067 * <attr> ::= PROTECTED |
8068 */
8069 case ATTR21:
8070 et_type = ET_PROTECTED;
8071 if (!IN_MODULE_SPEC) {
8072 error(155, 3, gbl.lineno,
8073 "PROTECTED may only appear in the specification part of a MODULE",
8074 CNULL);
8075 }
8076 break;
8077 /*
8078 * <attr> ::= ASYNCHRONOUS
8079 */
8080 case ATTR22:
8081 et_type = ET_ASYNCHRONOUS;
8082 break;
8083 /*
8084 * <attr> ::= ABSTRACT |
8085 */
8086 case ATTR23:
8087 /* anything here? */
8088 break;
8089 /*
8090 * <attr> ::= TEXTURE
8091 */
8092 case ATTR24:
8093 if (cuda_enabled("texture"))
8094 et_type = ET_TEXTURE;
8095 else
8096 et_type = 0;
8097 break;
8098
8099 /*
8100 * <attr> ::= KIND |
8101 */
8102 case ATTR25:
8103 et_type = ET_KIND;
8104 break;
8105 /*
8106 * <attr> ::= LEN |
8107 */
8108 case ATTR26:
8109 et_type = ET_LEN;
8110 break;
8111 /*
8112 * <attr> ::= CONTIGUOUS |
8113 */
8114 case ATTR27:
8115 et_type = ET_CONTIGUOUS;
8116 break;
8117 /*
8118 * <attr> ::= MANAGED |
8119 */
8120 case ATTR28:
8121 et_type = 0;
8122 if (cuda_enabled("managed")) {
8123#if defined(TARGET_OSX)
8124 /* not supported */
8125 error(538, 3, gbl.lineno, CNULL, CNULL);
8126#else
8127 /* supported */
8128 et_type = ET_MANAGED;
8129#endif
8130 }
8131 break;
8132
8133 /* ------------------------------------------------------------------ */
8134 /*
8135 * <bind attr> ::= ( <id name> ) |
8136 */
8137 case BIND_ATTR1:
8138 /* see also FUNC_SUFFIX2 for a copy of this processing */
8139
8140 bind_attr.exist = -1;
8141 bind_attr.altname = 0;
8142
8143 np = scn.id.name + SST_CVALG(RHS(2));
8144 if (sem_strcmp(np, "c") != 0) {
8145 error(4, 3, gbl.lineno, "Illegal BIND -", np);
8146 } else {
8148 }
8149
8150 break;
8151 /*
8152 * <bind attr> ::= ( <id name> , <id name> = <quoted string> )
8153 */
8154 case BIND_ATTR2:
8155 np = scn.id.name + SST_CVALG(RHS(4));
8156 if (sem_strcmp(np, "name") != 0) {
8157 error(4, 3, gbl.lineno, "Illegal BIND syntax. Expecting: NAME Got:", np);
8158 }
8159
8160 bind_attr.exist = -1;
8161 bind_attr.altname = 0;
8162
8163 np = scn.id.name + SST_CVALG(RHS(2));
8164 if (sem_strcmp(np, "c") != 0) {
8165 error(4, 3, gbl.lineno, "Illegal BIND -", np);
8166 } else {
8168 bind_attr.altname = SST_SYMG(RHS(6)); // altname may be ""
8169 }
8170
8171 break;
8172
8173 /* ------------------------------------------------------------------ */
8174 /*
8175 * <bind list> ::= <bind list> , <bind entry> |
8176 */
8177 case BIND_LIST1:
8178 rhstop = 3;
8179 goto add_sym_to_bind_list;
8180 break;
8181 /*
8182 * <bind list> ::= <bind entry>
8183 */
8184 case BIND_LIST2:
8185 break;
8186
8187 /* ------------------------------------------------------------------ */
8188 /*
8189 * <bind entry> ::= <common> |
8190 */
8191 case BIND_ENTRY1:
8192 /* fall through */
8193 /*
8194 * <bind entry> ::= <id>
8195 */
8196 case BIND_ENTRY2:
8197 rhstop = 1;
8198 add_sym_to_bind_list:
8199 itemp = (ITEM *)getitem(0, sizeof(ITEM));
8200 itemp->next = ITEM_END;
8201 itemp->t.sptr = SST_SYMG(RHS(rhstop));
8202 itemp->ast = SST_ASTG(RHS(rhstop)); /* copied for <access> rules */
8203 if (rhstop == 1)
8204 /* adding first item to list */
8205 SST_BEGP(LHS, itemp);
8206 else
8207 /* adding subsequent items to list */
8208 SST_ENDG(RHS(1))->next = itemp;
8209 SST_ENDP(LHS, itemp);
8210 break;
8211
8212 /* ------------------------------------------------------------------ */
8213 /*
8214 * <opt type spec> ::= |
8215 */
8216 case OPT_TYPE_SPEC1:
8217 entity_attr.access = ' ';
8218 SST_CVALP(LHS, 0);
8219 break;
8220 /*
8221 * <opt type spec> ::= , <type attr list>
8222 */
8223 case OPT_TYPE_SPEC2:
8224 SST_CVALP(LHS, SST_CVALG(RHS(2)));
8225 SST_LSYMP(LHS, SST_LSYMG(RHS(2)));
8226 break;
8227
8228 /* ------------------------------------------------------------------ */
8229 /*
8230 * <type attr list> ::= <type attr list> , <type attr> |
8231 */
8232 case TYPE_ATTR_LIST1:
8233 switch (SST_CVALG(RHS(1)) & SST_CVALG(RHS(3))) {
8234 case 0x1:
8235 error(134, 3, gbl.lineno, "- duplicate", et[ET_BIND].name);
8236 SST_CVALP(RHS(3), 0);
8237 break;
8238 case 0x2:
8239 error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name);
8240 SST_CVALP(RHS(3), 0);
8241 break;
8242 case 0x4: /* type extension */
8243 error(134, 3, gbl.lineno, "- duplicate", et[ET_ACCESS].name);
8244 SST_CVALP(RHS(3), 0);
8245 break;
8246 }
8247 SST_CVALP(LHS, SST_CVALG(RHS(1)) | SST_CVALG(RHS(3)));
8248 if (SST_CVALG(RHS(3)) & 0x4)
8249 SST_LSYMP(LHS, SST_LSYMG(RHS(3)));
8250 break;
8251 /*
8252 * <type attr list> ::= <type attr>
8253 */
8254 case TYPE_ATTR_LIST2:
8255 break;
8256
8257 /* ------------------------------------------------------------------ */
8258 /*
8259 * <type attr> ::= BIND <bind attr> |
8260 */
8261 case TYPE_ATTR1:
8262 /* struct types are already properly aligned for C compatibility;
8263 * pass up presence of BIND so that the type can be marked as
8264 * BIND(C) with the flag CFUNC.
8265 */
8266 SST_CVALP(LHS, 0x1);
8267 break;
8268 /*
8269 * <type attr> ::= <access spec>
8270 */
8271 case TYPE_ATTR2:
8272 SST_CVALP(LHS, 0x2);
8273 break;
8274 /*
8275 * <type attr> ::= EXTENDS ( <id> ) |
8276 */
8277 case TYPE_ATTR3:
8278 /* type extension */
8279 SST_CVALP(LHS, 0x4);
8280 sptr = SST_SYMG(RHS(3));
8281 while (STYPEG(sptr) == ST_ALIAS)
8282 sptr = SYMLKG(sptr);
8283 if (STYPEG(sptr) == ST_USERGENERIC && GTYPEG(sptr)) {
8284 sptr = GTYPEG(sptr);
8285 }
8286 if (sptr > NOSYM && STYPEG(sptr) != ST_TYPEDEF) {
8287 int sym = findByNameStypeScope(SYMNAME(sptr), ST_TYPEDEF, -1);
8288 if (sym > NOSYM)
8289 sptr = sym;
8290 }
8291 if (DTY(DTYPEG(sptr)) != TY_DERIVED) {
8292 error(155, 4, gbl.lineno, "Invalid type extension", NULL);
8293 } else {
8294 /* Check for private type extension */
8295
8296 int tag = DTY(DTYPEG(sptr) + 3);
8297 int tag_scope = SCOPEG(tag);
8298 int host_scope = stb.curr_scope;
8299
8300 if (PRIVATEG(tag)) {
8301 if (STYPEG(tag_scope) == ST_MODULE && STYPEG(host_scope) != ST_MODULE)
8302 host_scope = SCOPEG(host_scope);
8303 if (tag_scope != host_scope)
8304 error(155, 3, gbl.lineno,
8305 "Cannot extend type with PRIVATE attribute -", SYMNAME(tag));
8306 }
8307 }
8308 sem.extends = sptr;
8309 SST_LSYMP(LHS, sptr);
8310 break;
8311 /*
8312 * <type attr> ::= ABSTRACT |
8313 */
8314 case TYPE_ATTR4:
8315 SST_CVALP(LHS, 0x8);
8316 break;
8317
8318 /* ------------------------------------------------------------------ */
8319 /*
8320 * <access spec> ::= PUBLIC |
8321 */
8322 case ACCESS_SPEC1:
8323 entity_attr.access = 'u';
8324 if (!IN_MODULE_SPEC)
8325 ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL);
8326 break;
8327 /*
8328 * <access spec> ::= PRIVATE
8329 */
8330 case ACCESS_SPEC2:
8331 if (sem.type_mode == 2 && IN_MODULE_SPEC) {
8332 /* private seen in type bound procedure "contains" section */
8333 entity_attr.access = '0';
8334 } else
8335 entity_attr.access = 'v';
8336 if (!IN_MODULE_SPEC)
8337 ERR310("PUBLIC/PRIVATE may only appear in a MODULE scoping unit", CNULL);
8338 break;
8339
8340 /* ------------------------------------------------------------------ */
8341 /*
8342 * <access list> ::= <access list>, <access> |
8343 */
8344 case ACCESS_LIST1:
8345 rhstop = 3;
8346 goto add_sym_to_list;
8347 /*
8348 * <access list> ::= <access>
8349 */
8350 case ACCESS_LIST2:
8351 rhstop = 1;
8352 goto add_sym_to_list;
8353
8354 /* ------------------------------------------------------------------ */
8355 /*
8356 * <access> ::= <ident> |
8357 */
8358 case ACCESS1:
8359 SST_ASTP(LHS, 0);
8360 break;
8361 /*
8362 * <access> ::= <id name> ( <operator> ) |
8363 */
8364 case ACCESS2:
8365 np = scn.id.name + SST_CVALG(RHS(1));
8366 if (sem_strcmp(np, "operator") == 0)
8367 SST_SYMP(LHS, SST_LSYMG(RHS(3)));
8368 else {
8369 error(34, 3, gbl.lineno, np, CNULL);
8370 SST_SYMP(LHS, getsymbol(".34"));
8371 }
8372 SST_ASTP(LHS, 1); /* mark this as being from OPERATOR stmt */
8373 break;
8374 /*
8375 * <access> ::= <id name> ( = )
8376 */
8377 case ACCESS3:
8378 np = scn.id.name + SST_CVALG(RHS(1));
8379 if (sem_strcmp(np, "assignment") == 0) {
8381 SST_SYMP(LHS, sptr);
8382 } else {
8383 error(34, 3, gbl.lineno, np, CNULL);
8384 SST_SYMP(LHS, getsymbol(".34"));
8385 }
8386 SST_ASTP(LHS, 1); /* treat as if from OPERATOR stmt */
8387 break;
8388
8389 /* ------------------------------------------------------------------ */
8390 /*
8391 * <seq> ::= SEQUENCE |
8392 */
8393 case SEQ1:
8394 if (!INSIDE_STRUCT || STSK_ENT(0).type != 'd') {
8395 error(155, 3, gbl.lineno,
8396 "SEQUENCE must appear in a derived type definition", CNULL);
8397 }
8398 SST_CVALP(LHS, 's');
8399 break;
8400 /*
8401 * <seq> ::= NOSEQUENCE
8402 */
8403 case SEQ2:
8404 error(34, 3, gbl.lineno, "NOSEQUENCE", CNULL);
8405 SST_CVALP(LHS, 'n');
8406 break;
8407
8408 /* ------------------------------------------------------------------ */
8409 /*
8410 * <intent> ::= INTENT ( <id name> ) |
8411 */
8412 case INTENT1:
8413 np = scn.id.name + SST_CVALG(RHS(3));
8414 if (sem_strcmp(np, "in") == 0)
8415 entity_attr.intent = INTENT_IN;
8416 else if (sem_strcmp(np, "out") == 0)
8417 entity_attr.intent = INTENT_OUT;
8418 else if (sem_strcmp(np, "inout") == 0)
8419 entity_attr.intent = INTENT_INOUT;
8420 else {
8421 error(81, 3, gbl.lineno, "- illegal intent", np);
8422 entity_attr.intent = INTENT_DFLT;
8423 }
8424 break;
8425 /*
8426 * <intent> ::= INTENT ( <id name> <id name> )
8427 */
8428 case INTENT2:
8429 np = scn.id.name + SST_CVALG(RHS(3));
8430 if (sem_strcmp(np, "in") == 0) {
8431 np = scn.id.name + SST_CVALG(RHS(4));
8432 if (sem_strcmp(np, "out") == 0)
8433 entity_attr.intent = INTENT_INOUT;
8434 else {
8435 error(81, 3, gbl.lineno, "- illegal intent in", np);
8436 entity_attr.intent = INTENT_DFLT;
8437 }
8438 } else {
8439 error(81, 3, gbl.lineno, "- illegal intent", np);
8440 entity_attr.intent = INTENT_DFLT;
8441 }
8442 break;
8443
8444 /* ------------------------------------------------------------------ */
8445 /*
8446 * <entity decl list> ::= <entity decl list> , <entity decl> |
8447 */
8448 case ENTITY_DECL_LIST1:
8449 rhstop = 3;
8450 goto add_entity_to_list;
8451 /*
8452 * <entity decl list> ::= <entity decl>
8453 */
8454 case ENTITY_DECL_LIST2:
8455 rhstop = 1;
8456 add_entity_to_list:
8457 if (in_entity_typdcl) { /* only pass up list if hpf decls */
8459 break;
8460 }
8461 itemp = (ITEM *)getitem(0, sizeof(ITEM));
8462 itemp->next = ITEM_END;
8463 itemp->t.sptr = SST_SYMG(RHS(rhstop));
8464 if (rhstop == 1)
8465 /* adding first item to list */
8466 SST_BEGP(LHS, itemp);
8467 else
8468 /* adding subsequent items to list */
8469 SST_ENDG(RHS(1))->next = itemp;
8470 SST_ENDP(LHS, itemp);
8471 break;
8472
8473 /* ------------------------------------------------------------------ */
8474 /*
8475 * <entity decl> ::= <entity id> |
8476 */
8477 case ENTITY_DECL1:
8478 /* only pass up sym if hpf decls */
8479 if (!in_entity_typdcl)
8480 break;
8481
8482 inited = FALSE;
8483 goto entity_decl_shared;
8484 /*
8485 * <entity decl> ::= <entity id> <init beg> <expression> |
8486 */
8487 case ENTITY_DECL2:
8488 if (!in_entity_typdcl) {
8489 error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
8490 break;
8491 }
8492 sptr = SST_SYMG(RHS(1));
8493 stype1 = STYPEG(sptr);
8494 if (IS_INTRINSIC(stype1)) {
8495 if ((sptr = newsym(sptr)) == 0)
8496 /* Symbol frozen as an intrinsic, ignore in COMMON */
8497 break;
8498 SST_SYMP(LHS, sptr);
8499 }
8500 inited = TRUE;
8502 goto entity_decl_shared;
8503 /*
8504 * <entity decl> ::= <entity id> '=>' <id> ( )
8505 */
8506 case ENTITY_DECL3:
8507 if (!in_entity_typdcl) {
8508 error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
8509 break;
8510 }
8511 sptr = SST_SYMG(RHS(1));
8512 stype1 = STYPEG(sptr);
8513 if (IS_INTRINSIC(stype1)) {
8514 if ((sptr = newsym(sptr)) == 0)
8515 /* Symbol frozen as an intrinsic, ignore in COMMON */
8516 break;
8517 SST_SYMP(LHS, sptr);
8518 }
8519 sptr = SST_SYMG(RHS(3));
8520 sptr = refsym(sptr, OC_OTHER);
8521 SST_SYMP(RHS(3), sptr);
8522 SST_IDP(RHS(3), S_IDENT);
8524 (void)mkvarref(RHS(3), ITEM_END);
8526 inited = TRUE;
8527
8528 entity_decl_shared:
8529 sptr = SST_SYMG(RHS(1));
8530 if (!(entity_attr.exist & ET_B(ET_BIND))) {
8532 SST_SYMP(RHS(1), sptr);
8533 }
8534 SST_SYMP(RHS(1), sptr);
8535 if (sem.new_param_dt) {
8536 dtype = DTYPEG(sptr);
8537 if (DTY(dtype) == TY_ARRAY) {
8538 DTY(dtype + 1) = sem.new_param_dt;
8539 } else {
8540 DTYPEP(sptr, sem.new_param_dt);
8541 }
8543 }
8544
8545 if (!sem.interface)
8547
8548 if (sem.class && sem.type_mode &&
8549 !(entity_attr.exist & (ET_B(ET_ALLOCATABLE) | ET_B(ET_POINTER)))) {
8550 error(155, 3, gbl.lineno, "CLASS component must be "
8551 "allocatable or pointer -",
8552 SYMNAME(sptr));
8553 }
8554 sem.gdtype = SST_GDTYPEG(RHS(1));
8555 sem.gty = SST_GTYG(RHS(1));
8556 if (flg.xref)
8557 xrefput(sptr, 'd');
8558 dtype = mod_type(sem.gdtype, sem.gty, lenspec[1].kind, lenspec[1].len,
8559 lenspec[1].propagated, sptr);
8560 if (DCLDG(sptr) && !RESULTG(sptr) && !IS_INTRINSIC(STYPEG(sptr))) {
8561 switch (STYPEG(sptr)) {
8562 /* any cases for which a data type does not apply */
8563 case ST_MODULE:
8564 case ST_NML:
8565 error(44, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8566 break;
8567 default:
8568 /* data type for ident has already been specified */
8569 if (DDTG(DTYPEG(sptr)) == dtype)
8570 error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
8571 else
8572 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8573 }
8574 /* to avoid setting symbol table entry's stype field */
8575 goto entity_decl_end;
8576 } else {
8577 switch (STYPEG(sptr)) {
8578 /* any cases for which a type must be identical to the variable's
8579 * implicit type.
8580 */
8581 case ST_PARAM:
8582 if (!(entity_attr.exist & ET_B(ET_PARAMETER)) && DTYPEG(sptr) != dtype)
8583 error(37, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8584 break;
8585 default:
8586 break;
8587 }
8588 }
8589 /*
8590 * Finalize the dtype of the variable.
8591 * Determine the tentative stype we want give to the variable if
8592 * it's still ST_UNKNOWN or ST_IDENT.
8593 */
8594 DCLDP(sptr, TRUE);
8596
8597 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
8598 int dims, idx, lbast;
8599 if (sem.new_param_dt && has_type_parameter(DTY(DTYPEG(sptr) + 1))) {
8600 /* Make sure we use the new parameterized dtype */
8602 }
8603 DTY(DTYPEG(sptr) + 1) = dtype;
8604 if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3) &&
8605 DISTMEMG(DTY(dtype + 3))) {
8606 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8607 }
8608 dtype = DTYPEG(sptr);
8609 if (AD_ASSUMSZ(AD_DPTR(dtype)) && DTY(dtype + 1) == TY_INT &&
8610 SCG(sptr) != SC_DUMMY && !(entity_attr.exist & ET_B(ET_PARAMETER))) {
8611 error(155, 3, gbl.lineno,
8612 "Implied-shape array must have the PARAMETER attribute -",
8613 SYMNAME(sptr));
8614 goto entity_decl_end;
8615 }
8616 dims = AD_NUMDIM(AD_DPTR(dtype));
8617 for (idx = 0; idx < dims; idx++) {
8618 lbast = AD_LWAST(AD_DPTR(dtype), idx);
8619 if (AD_ASSUMSZ(AD_DPTR(dtype)) && DTY(dtype + 1) == TY_INT &&
8620 SCG(sptr) != SC_DUMMY && A_TYPEG(lbast) != A_CNST) {
8621 error(155, 3, gbl.lineno,
8622 "Implied-shape array lower bound is not constant -",
8623 SYMNAME(sptr));
8624 goto entity_decl_end;
8625 }
8626 }
8627 } else if (DTY(DTYPEG(sptr)) == TY_PTR &&
8628 DTY(DTY(DTYPEG(sptr) + 1)) == TY_PROC) {
8629 /* ptr to a function, set the func return value and the pointer flag */
8630 int func_dtype = DTY(DTYPEG(sptr) + 1);
8631 DTY(func_dtype + 5) = dtype;
8632 } else if (!USELENG(sptr) && !LENG(sptr)) {
8633 /* parameterized derived type TBD: array case???? */
8634 DTYPEP(sptr, (!sem.new_param_dt) ? dtype : sem.new_param_dt);
8635 if (SCG(sptr) == SC_DUMMY) {
8636 put_length_type_param(DTYPEG(sptr), 3);
8637 }
8638 }
8639 if (DTY(dtype) == TY_ARRAY)
8640 is_array = TRUE;
8641 else
8642 is_array = FALSE;
8643 is_member = FALSE;
8644 stype = STYPEG(sptr);
8645 if (stype == ST_MEMBER) {
8646 stype = 0;
8647 is_member = TRUE;
8648 } else if (stype == ST_ENTRY)
8649 stype = 0;
8650 else if (is_array)
8651 stype = ST_ARRAY;
8652 else if (DTY(dtype) == TY_STRUCT)
8653 stype = ST_STRUCT;
8654
8655 no_init = FALSE;
8656 et_type = 0;
8657 et_bitv = entity_attr.exist;
8658 /* Loop through all assigned attributes */
8659 for (; et_bitv; et_bitv >>= 1, et_type++) {
8660 if ((et_bitv & 0x0001) == 0)
8661 continue;
8662 switch (et_type) {
8663 default:
8664 continue;
8665 case ET_ACCESS:
8666 if (sptr == ST_ARRAY && ADJARRG(sptr))
8667 error(84, 3, gbl.lineno, SYMNAME(sptr),
8668 "- must not be an automatic array");
8669 else if (is_member) {
8670 if (entity_attr.access == 'v')
8671 PRIVATEP(sptr, 1);
8672 else
8673 PRIVATEP(sptr, 0);
8674 } else {
8675 accessp = (ACCL *)getitem(3, sizeof(ACCL));
8676 accessp->sptr = sptr;
8677 accessp->type = entity_attr.access;
8678 accessp->next = sem.accl.next;
8679 accessp->oper = ' ';
8680 sem.accl.next = accessp;
8681 }
8682 break;
8683 case ET_ALLOCATABLE:
8684 if (is_array) {
8685 ad = AD_DPTR(dtype);
8686 if (AD_DEFER(ad) == 0)
8687 error(84, 3, gbl.lineno, SYMNAME(sptr),
8688 "- must be a deferred shape array");
8689 else {
8690 if (AD_ASSUMSHP(ad)) {
8691 /* this is an error if it isn't a dummy; the
8692 * declaration could occur before its entry, so
8693 * the check needs to be performed in semfin.
8694 */
8695 ASSUMSHPP(sptr, 1);
8696 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
8697 SDSCS1P(sptr, 1);
8698 }
8700 }
8701 }
8702 ALLOCP(sptr, 1);
8703 ALLOCATTRP(sptr, 1);
8704 if (STYPEG(sptr) == ST_MEMBER) {
8705 ALLOCFLDP(DTY(ENCLDTYPEG(sptr) + 3), 1);
8706 }
8707
8708 dtype = DTYPEG(sptr);
8709 if (DTY(dtype) == TY_ARRAY) {
8710 dtype = DTY(dtype + 1);
8711 if (sem.class)
8712 CLASSP(sptr, 1);
8713 }
8714 if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED &&
8716 FINALIZEDP(sptr, 1);
8717 }
8718 if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) &&
8719 DTY(dtype) == TY_DERIVED) {
8720 /* Note: Do not execute this case for array
8721 * components since they already have a full array descriptor
8722 * embedded in the derived type.
8723 */
8724 if (sem.class)
8725 CLASSP(sptr, 1);
8729
8731
8732 if (SCG(sptr) != SC_DUMMY)
8733 SCP(sptr, SC_BASED);
8734 ALLOCDESCP(sptr, TRUE);
8735 } else if (SCG(sptr) == SC_DUMMY) {
8738 } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 &&
8739 (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
8740 DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) {
8741 if (SCG(sptr) != SC_DUMMY)
8742 SCP(sptr, SC_BASED); /* Don't change dummy */
8745 ALLOCDESCP(sptr, TRUE);
8746 } else {
8747 SCP(sptr, SC_BASED);
8748 }
8749 no_init = TRUE;
8750 break;
8751 case ET_CONTIGUOUS:
8752#ifdef CONTIGATTRP
8753 CONTIGATTRP(sptr, 1);
8754#endif
8755 break;
8756 case ET_DIMENSION:
8757 break;
8758 case ET_EXTERNAL:
8759 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
8760 /* conflict with EXTERNAL */
8761 error(134, 3, gbl.lineno, "- array bounds not allowed with external",
8762 SYMNAME(sptr));
8763 }
8764 /* Produce procedure symbol based on attributes */
8766 sptr =
8768 if (!TYPDG(sptr)) {
8769 TYPDP(sptr, 1);
8770 if (SCG(sptr) == SC_DUMMY) {
8771 IS_PROC_DUMMYP(sptr, 1);
8772 }
8773 }
8774 stype = 0;
8775 no_init = TRUE;
8776 break;
8777 case ET_INTENT:
8778 INTENTP(sptr, entity_attr.intent);
8779 if (sem.interface) {
8780 if (SCG(sptr) != SC_DUMMY) {
8781 error(134, 3, gbl.lineno,
8782 "- intent specified for nondummy argument", SYMNAME(sptr));
8783 } else if (POINTERG(sptr)) {
8784 error(134, 3, gbl.lineno, "- intent specified for pointer argument",
8785 SYMNAME(sptr));
8786 } else if (STYPEG(sptr) == ST_PROC) {
8787 error(134, 3, gbl.lineno,
8788 "- intent specified for dummy subprogram argument",
8789 SYMNAME(sptr));
8790 }
8791 } else {
8792 /* defer checking of storage class until semfin */
8793 itemp1 = (ITEM *)getitem(3, sizeof(ITEM));
8794 itemp1->next = sem.intent_list;
8795 sem.intent_list = itemp1;
8796 itemp1->t.sptr = sptr;
8797 itemp1->ast = gbl.lineno;
8798 }
8799 break;
8800 case ET_INTRINSIC:
8801 stype = STYPEG(sptr);
8802 if (IS_INTRINSIC(stype)) {
8803 EXPSTP(sptr, 1); /* Freeze as an intrinsic */
8804 TYPDP(sptr, 1); /* appeared in INTRINSIC statement */
8805 } else
8806 error(126, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8807 stype = 0;
8808 no_init = TRUE;
8809 break;
8810 case ET_OPTIONAL:
8811 OPTARGP(sptr, 1);
8812 break;
8813 case ET_PARAMETER:
8814 break; /* handle after scanning all attributes */
8815 case ET_POINTER:
8816 POINTERP(sptr, TRUE);
8817 if (sem.contiguous)
8818 CONTIGATTRP(sptr, 1);
8819 if (DTYG(DTYPEG(sptr)) == TY_DERIVED && XBIT(58, 0x40000)) {
8820 F90POINTERP(sptr, TRUE);
8821 }
8822 if (is_array) {
8823 ad = AD_DPTR(dtype);
8824 if (AD_DEFER(ad) == 0)
8825 error(84, 3, gbl.lineno, SYMNAME(sptr),
8826 "- must be a deferred shape array");
8827 }
8828 dtype = DTYPEG(sptr);
8829 if (DTY(dtype) == TY_ARRAY) {
8830 dtype = DTY(dtype + 1);
8831 if (sem.class)
8832 CLASSP(sptr, 1);
8833 }
8834 if (STYPEG(sptr) == ST_MEMBER && DTY(dtype) == TY_DERIVED &&
8836 FINALIZEDP(sptr, 1);
8837 }
8838 if (!(DTY(DTYPEG(sptr)) == TY_ARRAY && STYPEG(sptr) == ST_MEMBER) &&
8839 DTY(dtype) == TY_DERIVED) {
8840 int sav_sc;
8841 if (sem.class)
8842 CLASSP(sptr, TRUE);
8844 sav_sc = 0;
8845 if (IN_MODULE && in_save_scope(sptr)) {
8846 /* SAVE is set, so we need to set our descriptor
8847 * to SC_STATIC here instead of later (in do_save() of
8848 * semfin.c). Otherwise, we may get unresolved symbol
8849 * link errors because we save descriptor early on in
8850 * the module.
8851 */
8852 /* Note: The SC_STATIC fix is only required for polymorphic
8853 * objects. For non-polymorphic objects, we can safely use
8854 * SC_LOCAL since the type does not mutate.
8855 */
8856 sav_sc = get_descriptor_sc();
8857 set_descriptor_sc(sem.class ? SC_STATIC : SC_LOCAL);
8858 }
8859 if (sem.class || has_tbp_or_final(dtype) ||
8860 STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY) {
8861 ALLOCDESCP(sptr, TRUE);
8862 }
8865 if (IN_MODULE && in_save_scope(sptr)) {
8866 set_descriptor_sc(sav_sc);
8867 }
8868 if (!sem.class)
8869 CCSYMP(SDSCG(sptr), TRUE);
8870 } else if (!INSIDE_STRUCT && SDSCG(sptr) == 0 &&
8871 (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
8872 DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) {
8873 if (SCG(sptr) != SC_DUMMY) /* Can't change dummy */
8874 SCP(sptr, SC_BASED);
8877 }
8878 break;
8879 case ET_SAVE:
8880/* <ident> must be a variable or an array; it cannot be a dummy
8881 * argument or common block member.
8882 */
8883 if (stype == 0)
8884 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8885 else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr))) {
8886 if (ASUMSZG(sptr))
8887 error(155, 3, gbl.lineno,
8888 "An assumed-size array cannot have the SAVE attribute -",
8889 SYMNAME(sptr));
8890 else if (SCG(sptr) == SC_DUMMY)
8891 error(155, 3, gbl.lineno,
8892 "An adjustable array cannot have the SAVE attribute -",
8893 SYMNAME(sptr));
8894 else
8895 error(155, 3, gbl.lineno,
8896 "An automatic array cannot have the SAVE attribute -",
8897 SYMNAME(sptr));
8898 } else if (flg.standard && gbl.currsub && !is_impure(gbl.currsub)) {
8899 error(170, 2, gbl.lineno,
8901 "SAVE attribute for a BLOCK variable of a PURE subroutine" :
8902 "SAVE attribute for a local variable of a PURE subroutine",
8903 CNULL);
8904 } else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8905 SCG(sptr) == SC_BASED) &&
8906 (stype == ST_VAR || stype == ST_ARRAY ||
8907 stype == ST_STRUCT || stype == ST_IDENT)) {
8908 sem.savloc = TRUE;
8909 SAVEP(sptr, 1);
8910 /* SCP(sptr, SC_LOCAL);
8911 * SAVE is now an attribute and may appear allocatable; the
8912 * appearance of a variable in a SAVE statement is no longer
8913 * sufficient to define the variable's storage class.
8914 */
8915 } else
8916 error(39, 2, gbl.lineno, SYMNAME(sptr), CNULL);
8917 break;
8918 case ET_TARGET:
8919 TARGETP(sptr, 1);
8920 if( XBIT(58, 0x400000) && SCG(sptr) == SC_DUMMY && ASSUMSHPG(sptr) )
8921 SDSCS1P(sptr,0);
8922 break;
8923 case ET_AUTOMATIC:
8924 /* <ident> must be a variable or an array; it cannot be a dummy
8925 * argument or common block member.
8926 */
8927 if (stype == 0)
8928 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8929 else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr)))
8930 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8931 else if (flg.standard)
8932 error(171, 2, gbl.lineno, "AUTOMATIC", CNULL);
8933 else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8934 SCG(sptr) == SC_BASED) &&
8935 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8936 stype == ST_IDENT)) {
8937 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr))
8938 symatterr(2, sptr, "AUTOMATIC");
8939 else if (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr)) {
8940 sem.autoloc = TRUE;
8941 /* TBD -- need to resolve SC_BASED vs SC_LOCAL & SCFXD
8942 * DON'T FORGET the AUTOMATIC & STATIC statements.
8943 */
8944 SCP(sptr, SC_LOCAL);
8945 SCFXDP(sptr, 1);
8946 }
8947 } else
8948 symatterr(2, sptr, "AUTOMATIC");
8949 break;
8950 case ET_STATIC:
8951 /* <ident> must be a variable or an array; it cannot be a dummy
8952 * argument or common block member.
8953 */
8954 if (stype == 0)
8955 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8956 else if (stype == ST_ARRAY && (ASUMSZG(sptr) || ADJARRG(sptr)))
8957 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
8958 else if (flg.standard)
8959 error(171, 2, gbl.lineno, "STATIC", CNULL);
8960 else if ((SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL ||
8961 SCG(sptr) == SC_BASED) &&
8962 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_STRUCT ||
8963 stype == ST_IDENT)) {
8964 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr))
8965 symatterr(2, sptr, "STATIC");
8966 /* just use the save semantics */
8967 sem.savloc = TRUE;
8968 SAVEP(sptr, 1);
8969 } else
8970 symatterr(2, sptr, "STATIC");
8971 break;
8972 case ET_BIND:
8973 if (!IN_MODULE)
8974 error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
8976 break;
8977 case ET_VALUE:
8978 if (CLASSG(sptr)) {
8979 error(155, 3, gbl.lineno, "Polymorphic variable"
8980 " cannot have VALUE attribute -",
8981 SYMNAME(sptr));
8982 }
8983 if ((DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR) &&
8984 string_length(DTYPEG(sptr)) != 1) {
8985 error(155, 3, gbl.lineno,
8986 "Multi-CHARACTER strings can not have the VALUE attribue - ",
8987 SYMNAME(sptr));
8988 }
8989 PASSBYVALP(sptr, 1);
8990 PASSBYREFP(sptr, 0);
8991 break;
8992 case ET_VOLATILE:
8993 VOLP(sptr, 1);
8994 break;
8995 case ET_ASYNCHRONOUS:
8996/*
8997 * do we need a specific flag set a flag? OR, just hit it
8998 * with VOLP? Wait until it really matters.
8999 */
9000#ifdef ASYNCP
9001 /* Yes, flag is needed so we can check
9002 * characteristics of dummy arguments for type bound
9003 * procedures.
9004 */
9005 ASYNCP(sptr, 1);
9006#endif
9007 break;
9008 case ET_PROTECTED:
9009 PROTECTEDP(sptr, 1);
9010 break;
9011 case ET_KIND:
9012#ifdef KINDP
9013 if (!DT_ISINT(DTYPEG(sptr))) {
9014 error(155, 3, gbl.lineno,
9015 "derived type parameter must be an INTEGER -", SYMNAME(sptr));
9016 }
9017 KINDP(sptr, -1);
9018#endif
9019 break;
9020 case ET_LEN:
9021#ifdef KINDP
9022 if (!DT_ISINT(DTYPEG(sptr))) {
9023 error(155, 3, gbl.lineno,
9024 "derived type parameter must be an INTEGER -", SYMNAME(sptr));
9025 }
9026 KINDP(sptr, -1);
9027 LENPARMP(sptr, 1);
9028#endif
9029 break;
9030 }
9031 }
9032 if (sem.new_param_dt)
9034 if ((DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_DEFERNCHAR) &&
9035 (!POINTERG(sptr) && !ALLOCATTRG(sptr))) {
9036 error(155, 3, gbl.lineno, "Object with deferred character length"
9037 " (:) must be a pointer or an allocatable -",
9038 SYMNAME(sptr));
9039 }
9040
9041 if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY &&
9042 (entity_attr.exist & ET_B(ET_PARAMETER))) {
9043 error(155, ERR_Severe, gbl.lineno, "Function result cannot have the"
9044 " PARAMETER attribute -",
9045 SYMNAME(sptr));
9046 goto entity_decl_end;
9047 }
9048 if ((entity_attr.exist & ET_B(ET_PARAMETER)) ||
9050 SST_IDG(RHS(3)))) {
9051 if (inited) {
9052 if (DTY(dtype) == TY_ARRAY && AD_ASSUMSZ(AD_DPTR(dtype)) &&
9053 DTY(SST_DTYPEG(RHS(3))) != TY_ARRAY) {
9054 error(155, 3, gbl.lineno, "Implied-shape array must be initialized "
9055 "with a constant array -", SYMNAME(sptr));
9056 goto entity_decl_end;
9057 }
9059 /* Don't build ACLS for scalar or unknown data type array parameters. */
9060 if (((DTY(dtype) != TY_DERIVED) && (DTY(dtype) != TY_ARRAY)) ||
9061 ((DTY(dtype) == TY_ARRAY) && (DTY(dtype + 1) == DT_NONE))) {
9062 goto entity_decl_end;
9063 }
9064 } else {
9065 error(143, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9066 goto entity_decl_end;
9067 }
9068 }
9069
9070 if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) {
9071 if (inited) {
9072 error(155, ERR_Severe, gbl.lineno, "Function result cannot have"
9073 " an initializer -",
9074 SYMNAME(sptr));
9075 goto entity_decl_end;
9076 }
9077 /* set the type for the entry point as well */
9079 }
9080 if (stype) {
9081 if (stype != STYPEG(sptr) && STYPEG(sptr) != ST_PARAM) {
9082 if (STYPEG(sptr) == ST_VAR && stype == ST_ARRAY) {
9083 /* HACK: if the item being defined has an initializer
9084 * that contains an intrinsic call that uses the item
9085 * as an argument, then the argument handling may have
9086 * changed the item's STYPE to ST_VAR. If the item is
9087 * an array, change its STYPE to ST_IDENT so declsym
9088 * will function correctly.
9089 */
9090 STYPEP(sptr, ST_IDENT);
9091 }
9092 sptr = declsym(sptr, stype, TRUE);
9093 }
9094 if (stype == ST_ARRAY && !F90POINTERG(sptr)) {
9095 if (POINTERG(sptr) || MDALLOCG(sptr) ||
9096 (ALLOCATTRG(sptr) && STYPEG(sptr) == ST_MEMBER)) {
9097 int dty = DTYPEG(sptr);
9100 if (DTY(dty) == TY_ARRAY) {
9101 dty = DTY(dty + 1);
9102 }
9103 if (DTY(dty) == TY_DERIVED && SCG(sptr) != SC_DUMMY) {
9104 /* initialize the type field in the descriptor */
9105 int astnew, type;
9107 astnew = mk_set_type_call(mk_id(SDSCG(sptr)), mk_id(type), FALSE);
9108 add_stmt(astnew);
9109 }
9110 }
9111 }
9112 }
9113 if (INSIDE_STRUCT && XBIT(58, 0x10000) && !F90POINTERG(sptr)) {
9114 /* we are processing a member, and we must handle all pointers */
9115 /* do we need descriptors for this member? */
9116 if (POINTERG(sptr) || ALLOCG(sptr) || ADJARRG(sptr) || RUNTIMEG(sptr)) {
9117 set_preserve_descriptor(ALLOCDESCG(sptr));
9120 SCP(sptr, SC_BASED);
9122 }
9123 }
9124 if (inited) { /* check if symbol is data initialized */
9125 if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
9126 if (no_init) {
9127 error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9128 goto entity_decl_end;
9129 }
9130 stsk = &STSK_ENT(0);
9131 if (SST_IDG(RHS(3)) == S_LVALUE || SST_IDG(RHS(3)) == S_EXPR ||
9132 SST_IDG(RHS(3)) == S_IDENT || SST_IDG(RHS(3)) == S_CONST) {
9133 mkexpr(RHS(3));
9134 ast = SST_ASTG(RHS(3));
9135 if (has_kind_parm_expr(ast, stsk->dtype, 1)) {
9136 if (chk_kind_parm_expr(ast, stsk->dtype, 1, 1)) {
9137 INITKINDP(sptr, 1);
9138 PARMINITP(sptr, ast);
9139 }
9140 } else if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
9141 int dim;
9142 ad = AD_DPTR(DTYPEG(sptr));
9143 for (dim = 0; dim < AD_NUMDIM(ad); ++dim) {
9144 int lb = AD_LWAST(ad, dim);
9145 int ub = AD_UPAST(ad, dim);
9146 if (has_kind_parm_expr(lb, stsk->dtype, 1) ||
9148 INITKINDP(sptr, 1);
9149 PARMINITP(sptr, ast);
9150 break;
9151 }
9152 }
9153 }
9154 }
9155 if (!INITKINDG(sptr))
9156 construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
9157 if (!SST_ACLG(RHS(3))) {
9158 goto entity_decl_end;
9159 }
9160
9161 ict = SST_ACLG(RHS(3));
9162 ict->sptr = sptr; /* field/component sptr */
9163 save_struct_init(ict);
9164 stsk = &STSK_ENT(0);
9165 if (stsk->ict_beg) {
9166 (stsk->ict_end)->next = SST_ACLG(RHS(3));
9167 stsk->ict_end = SST_ACLG(RHS(3));
9168 } else {
9169 stsk->ict_beg = SST_ACLG(RHS(3));
9170 stsk->ict_end = SST_ACLG(RHS(3));
9171 }
9172 } else {
9173 /* Data item (not TYPE component) initialization */
9174 if (no_init) {
9175 error(114, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9176 goto entity_decl_end;
9177 }
9178
9179 if (DTY(DTYPEG(sptr)) == TY_ARRAY && !POINTERG(sptr)) {
9180 if (ADD_DEFER(DTYPEG(sptr)) || ADD_NOBOUNDS(DTYPEG(sptr))) {
9181 error(155, 3, gbl.lineno, "Cannot initialize deferred-shape array",
9182 SYMNAME(sptr));
9183 goto entity_decl_end;
9184 }
9185 }
9186 if (POINTERG(sptr)) {
9187 /* have
9188 * ... :: <ptr> => NULL()
9189 * <ptr>$p, <ptr>$o, <ptr>$sd will be needed */
9190 dtype = DTYPEG(sptr);
9191 if (DTY(dtype) == TY_ARRAY) {
9192 dtype = DTY(dtype + 1);
9193 }
9194 if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) &&
9195 DTY(dtype) == TY_DERIVED &&
9197 STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY))
9200
9201 if ((DTY(DTYPEG(sptr)) != TY_ARRAY || STYPEG(sptr) != ST_MEMBER) &&
9202 DTY(dtype) == TY_DERIVED &&
9204 STYPEG(sptr) == ST_MEMBER || DTY(DTYPEG(sptr)) == TY_ARRAY))
9207 }
9208
9209 if (SST_IDG(RHS(3)) == S_ACONST) {
9210 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
9211 if (AD_NUMDIM(AD_DPTR(DTYPEG(sptr))) !=
9213 if (size_of_array(DTYPEG(sptr)) == 0 &&
9214 DTY(SST_DTYPEG(RHS(3))) != TY_ARRAY) {
9215 /* i.e., a(0) == (/integer::/) */
9216 goto entity_decl_end;
9217 }
9218 error(155, 3, gbl.lineno,
9219 "Shape of initializer does not match shape of",
9220 SYMNAME(sptr));
9221 goto entity_decl_end;
9222 }
9223 } else if (POINTERG(sptr) || ALLOCATTRG(sptr)) {
9224 errsev(457);
9225 goto entity_decl_end;
9226 }
9227 }
9228 construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
9229 if (!SST_ACLG(RHS(3))) {
9230 goto entity_decl_end;
9231 }
9232
9233 dtype = DTYPEG(sptr);
9234 if (STYPEG(sptr) == ST_PARAM) {
9235 if (DTY(dtype) == TY_ARRAY || DTY(dtype) == TY_DERIVED) {
9237 sptr = CONVAL1G(sptr);
9238 }
9239 } else if (DTY(dtype) == TY_DERIVED && !POINTERG(sptr)) {
9240 /* This used to be done in dinit_struct_constr. It is necessary */
9241 /* to get ADDRESS (i.e., offset into STATICS) set */
9242 if (STYPEG(sptr) == ST_IDENT || STYPEG(sptr) == ST_UNKNOWN) {
9243 STYPEP(sptr, ST_VAR);
9244 }
9245 if (SCG(sptr) == SC_NONE)
9246 SCP(sptr, SC_LOCAL);
9247 DINITP(sptr, 1);
9249 }
9250
9251 ast = mk_id(sptr);
9252 SST_ASTP(RHS(1), ast);
9253 SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1))));
9254 SST_SHAPEP(RHS(1), A_SHAPEG(ast));
9255 ivl = dinit_varref(RHS(1));
9256 dinit(ivl, SST_ACLG(RHS(3)));
9257 }
9258 } else if (DTY(DDTG(dtype)) == TY_DERIVED && !POINTERG(sptr) &&
9259 !ALLOCG(sptr) && !ADJARRG(sptr)) {
9260 int dt_dtype = DDTG(dtype);
9261
9262 if (INSIDE_STRUCT) {
9263 /* Uninitialized declaration of a derived type data item.
9264 * Check for and handle any component intializations defined
9265 * for this derived type */
9266 build_typedef_init_tree(sptr, dt_dtype);
9267 } else if (DTY(dt_dtype + 5) && SCOPEG(sptr) &&
9268 SCOPEG(sptr) == stb.curr_scope &&
9269 STYPEG(stb.curr_scope) == ST_MODULE) {
9270 /*
9271 * a derived type module variable has component initializers,
9272 * so generate inits.
9273 */
9274 build_typedef_init_tree(sptr, dt_dtype);
9275 }
9276 } else {
9277 if (POINTERG(sptr)) {
9278
9279 /* have
9280 * ... :: <ptr>
9281 * <ptr>$p, <ptr>$o, <ptr>$sd will be needed */
9282 if (!SDSCG(sptr))
9284
9285 if (!PTROFFG(sptr))
9287 }
9288 }
9289
9290 entity_decl_end:
9292 break;
9293
9294 /* ------------------------------------------------------------------ */
9295 /*
9296 * <entity id> ::= <ident> <opt len spec> |
9297 */
9298 case ENTITY_ID1:
9299 set_len_attributes(RHS(2), 1);
9300 stype = ST_IDENT;
9301 dtype = -1;
9302 dtypeset = 0;
9303 sem.dinit_count = 1;
9304 if (entity_attr.exist & ET_B(ET_DIMENSION)) {
9305 if (entity_attr.dimension) {
9306 /* allow just one use of this data type record */
9307 dtype = entity_attr.dimension;
9308 dtypeset = 1;
9309 entity_attr.dimension = 0;
9310 } else {
9311 /* create a new array dtype record from the bounds information
9312 * saved earlier
9313 */
9314 BCOPY(sem.bounds, entity_attr.bounds, char, sizeof(sem.bounds));
9315 BCOPY(&sem.arrdim, entity_attr.arrdim, char, sizeof(sem.arrdim));
9316 dtype = mk_arrdsc();
9317 dtypeset = 1;
9318 }
9319 ad = AD_DPTR(dtype);
9320 if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))
9321 sem.dinit_count = -1;
9322 stype = ST_ARRAY;
9323 } else
9324 ad = NULL;
9325 goto entity_id_shared;
9326 /*
9327 * <entity id> ::= <ident> <opt len spec> <dim beg> <dimension list> ) <opt
9328 *len spec>
9329 */
9330 case ENTITY_ID2:
9331 /* Send len spec up with ident on semantic stack */
9332 if (SST_SYMG(RHS(6)) != -1) {
9333 if (SST_SYMG(RHS(2)) != -1)
9334 errsev(46);
9335 set_len_attributes(RHS(6), 1);
9336 } else
9337 set_len_attributes(RHS(2), 1);
9338 stype = ST_ARRAY;
9339 dtype = SST_DTYPEG(RHS(4));
9340 dtypeset = 1;
9341 ad = AD_DPTR(dtype);
9342 if (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad) || sem.interface)
9343 sem.dinit_count = -1;
9344 else
9346 entity_id_shared:
9347 sptr = SST_SYMG(RHS(1));
9348 if (!(entity_attr.exist & ET_B(ET_BIND))) {
9350 SST_SYMP(RHS(1), sptr);
9351 }
9356 }
9357 if (INSIDE_STRUCT) {
9358 /* this may be an HPF directive in a derived type */
9359 stsk = &STSK_ENT(0);
9360 if (sem.is_hpf && STYPEG(sptr) == ST_MEMBER &&
9361 ENCLDTYPEG(sptr) == stsk->dtype) {
9362 /* do nothing */
9363 } else {
9364 if (STYPEG(sptr) != ST_UNKNOWN)
9366 SYMLKP(sptr, NOSYM);
9367 STYPEP(sptr, ST_MEMBER);
9368 if (!dtypeset)
9369 dtype = sem.gdtype;
9370 DTYPEP(sptr, dtype); /* must be done before link members */
9371 if (sem.kind_type_param) {
9372 USEKINDP(sptr, 1);
9373 if (sem.kind_candidate) {
9374 /* Save kind expression in component */
9376 KINDASTP(sptr, SST_ASTG(sem.kind_candidate->t.stkp));
9377 }
9378 KINDP(sptr, sem.kind_type_param);
9379 }
9380 if (sem.len_type_param) {
9381 USELENP(sptr, 1);
9382 LENP(sptr, sem.len_type_param);
9383 }
9384 if (sem.len_candidate) {
9385 int ty = DTY(DTYPEG(sptr));
9386 if (ty == TY_CHAR || ty == TY_NCHAR)
9387 {
9389 ty = get_type(2, ty, ast);
9390 DTYPEP(sptr, ty);
9391 USELENP(sptr, 1);
9392 sem.len_candidate = 0;
9394 }
9395 }
9396 if (DTY(dtype) == TY_ARRAY) {
9397 int d;
9398 d = DTY(dtype + 1);
9399 if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
9400 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9401 }
9402 }
9403 /* link field-namelist into member list at this level */
9405 if (stype == ST_ARRAY && STSK_ENT(0).type != 'd' &&
9406 (AD_ASSUMSZ(ad) || AD_ADJARR(ad) || AD_DEFER(ad))) {
9407 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9408 }
9409 if (stype == ST_ARRAY) {
9410 if (entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) {
9411 ALLOCP(sptr, 1);
9412 } else if (STSK_ENT(0).type == 'd') {
9413 /* error message wasn't issued above for derived type.
9414 * issue one now
9415 */
9416 if (AD_DEFER(ad)) {
9417 error(84, 3, gbl.lineno, SYMNAME(sptr),
9418 "- deferred shape array must have the POINTER "
9419 "or ALLOCATABLE attribute in a derived type");
9420 entity_attr.exist |= ET_B(ET_POINTER);
9421 } else if (AD_ASSUMSZ(ad) || AD_ADJARR(ad)) {
9422 if (AD_ADJARR(ad)) {
9423 int bndast, badArray;
9424 int numdim = AD_NUMDIM(ad);
9425 for (badArray = i = 0; i < numdim; i++) {
9426 bndast = AD_LWAST(ad, i);
9427 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
9428 if (!badArray) {
9429 bndast = AD_UPAST(ad, i);
9430 badArray = !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 0);
9431 if (!badArray) {
9432 ADJARRP(sptr, 1);
9433 USELENP(sptr, 1);
9434 break;
9435 }
9436 }
9437 }
9438 if (badArray) {
9439 for (badArray = i = 0; i < numdim; i++) {
9440 bndast = AD_LWAST(ad, i);
9441 badArray =
9442 !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
9443 if (badArray) {
9444 badArray =
9445 !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
9446 if (!badArray) {
9447 ADJARRP(sptr, 1);
9448 USELENP(sptr, 1);
9449 break;
9450 }
9451 }
9452 if (badArray) {
9453 goto illegal_array;
9454 }
9455 bndast = AD_UPAST(ad, i);
9456 badArray =
9457 !chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0);
9458 if (badArray) {
9459 badArray =
9460 !chk_len_parm_expr(bndast, ENCLDTYPEG(sptr), 1);
9461 if (!badArray) {
9462 ADJARRP(sptr, 1);
9463 USELENP(sptr, 1);
9464 break;
9465 }
9466 } else if (A_TYPEG(bndast) != A_ID &&
9467 A_TYPEG(bndast) != A_CNST) {
9468
9469 ADJARRP(sptr, 1);
9470 USELENP(sptr, 1);
9471 if (chk_kind_parm_expr(bndast, ENCLDTYPEG(sptr), 1, 0)) {
9472 USEKINDP(sptr, 1);
9473 }
9474 break;
9475 }
9476 if (badArray) {
9477 goto illegal_array;
9478 }
9479 }
9480 }
9481 } else {
9482 illegal_array:
9483 error(84, 3, gbl.lineno, SYMNAME(sptr),
9484 "- array must have constant bounds "
9485 "in a derived type");
9486 entity_attr.exist |= ET_B(ET_POINTER);
9487 }
9488 }
9489 }
9490 if (DTY(dtype) == TY_ARRAY) {
9491 int d;
9492 d = DTY(dtype + 1);
9493 if (DTY(d) == TY_DERIVED && DTY(d + 3) && DISTMEMG(DTY(d + 3))) {
9494 error(451, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9495 }
9496 }
9497 }
9498 if (DTY(sem.gdtype) == TY_DERIVED && (stsk->type == 'd')) {
9499 /* outer derived type has SEQUENCE, nested one should too */
9500
9501 if (SEQG(DTY(stsk->dtype + 3)) && DCLDG(DTY(sem.gdtype + 3)) &&
9502 !SEQG(DTY(sem.gdtype + 3))) {
9503 error(155, 3, gbl.lineno,
9504 "SEQUENCE must be set for nested derived type",
9505 SYMNAME(DTY(sem.gdtype + 3)));
9506 }
9507 if (DTY(stsk->dtype + 3) == DTY(sem.gdtype + 3)) {
9508 if ((entity_attr.exist & ET_B(ET_POINTER)) == 0) {
9509 error(155, 3, gbl.lineno, "Derived type component must "
9510 "have the POINTER attribute -",
9511 SYMNAME(sptr));
9512 }
9513 } else if ((entity_attr.exist & ET_B(ET_POINTER)) == 0 &&
9514 !DCLDG(DTY(sem.gdtype + 3)))
9515 error(155, 4, gbl.lineno, "Derived type has not been declared -",
9516 SYMNAME(DTY(sem.gdtype + 3)));
9517 }
9518 }
9519
9520 } else {
9521 sptr = create_var(sptr);
9522 if (sem.kind_type_param) {
9523 USEKINDP(sptr, 1);
9524 KINDP(sptr, sem.kind_type_param);
9525 }
9526 if (sem.len_type_param) {
9527 USELENP(sptr, 1);
9528 LENP(sptr, sem.len_type_param);
9529 }
9530 if (DTY(sem.stag_dtype) == TY_DERIVED && sem.class) {
9531 /* TBD - Probably need to fix this condition when we
9532 * support unlimited polymorphic entities.
9533 */
9534 if (SCG(sptr) == SC_DUMMY ||
9536 CLASSP(sptr, 1); /* mark polymorphic variable */
9537 if (PASSBYVALG(sptr)) {
9538 error(155, 3, gbl.lineno, "Polymorphic variable cannot have VALUE"
9539 " attribute -",
9540 SYMNAME(sptr));
9541 }
9542 if (DTY(sem.stag_dtype) == TY_DERIVED) {
9543 int tag = DTY(sem.stag_dtype + 3);
9544 if (CFUNCG(tag)) {
9545 error(155, 3, gbl.lineno,
9546 "Polymorphic variable cannot be declared "
9547 "with a BIND(C) derived type - ",
9548 SYMNAME(sptr));
9549 }
9550 if (SEQG(tag)) {
9551 error(155, 3, gbl.lineno,
9552 "Polymorphic variable cannot be declared "
9553 "with a SEQUENCE derived type - ",
9554 SYMNAME(sptr));
9555 }
9556 }
9557
9558 } else {
9559 error(155, 3, gbl.lineno, "Polymorphic variable must be a pointer, "
9560 "allocatable, or dummy object - ",
9561 SYMNAME(sptr));
9562 }
9563 }
9564 if (DTY(sem.stag_dtype) == TY_DERIVED && sem.which_pass &&
9565 !(entity_attr.exist & (ET_B(ET_POINTER) | ET_B(ET_ALLOCATABLE))) &&
9566 SCG(sptr) != SC_DUMMY && !FVALG(sptr) &&
9567 (gbl.rutype != RU_PROG || CONSTRUCTSYMG(sptr))) {
9569 }
9570 if (STYPEG(sptr) == ST_PROC && SCOPEG(sptr) &&
9571 SCOPEG(sptr) == stb.curr_scope && sem.which_pass &&
9572 gbl.rutype == RU_FUNC) {
9573 /* sptr is the ST_PROC for an ENTRY statement to appear later.
9574 * make a new sptr */
9575 sptr = insert_sym(sptr);
9576 }
9577 SST_SYMP(LHS, sptr);
9578 stype1 = STYPEG(sptr);
9579 /* Assertion:
9580 * stype = stype we want to make symbol {ARRAY or IDENT}
9581 * stype1 = symbol's current stype
9582 */
9583 if (stype == ST_ARRAY) {
9584 if (IS_INTRINSIC(stype1)) {
9585 /* Changing intrinsic symbol to ARRAY */
9586 if ((sptr = newsym(sptr)) == 0)
9587 /* Symbol frozen as an intrinsic, ignore type decl */
9588 break;
9589 SST_SYMP(LHS, sptr);
9590 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
9591 stype1 = ST_UNKNOWN;
9592 } else if (stype1 == ST_ENTRY) {
9593 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
9594 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9595 break;
9596 }
9597 } else if (stype1 == ST_ARRAY) {
9598 /* if symbol is already an array, check if the dimension
9599 * specifiers are identical.
9600 */
9601 ADSC *ad1, *ad2;
9602 int ndim;
9603
9604 ad1 = AD_DPTR(DTYPEG(sptr));
9605 /* dtype must be set */
9606 assert(dtypeset, "semant: dtype was not set", dtype, 3);
9607 ad2 = AD_DPTR(dtype);
9608 ndim = AD_NUMDIM(ad1);
9609 if (ndim != AD_NUMDIM(ad2)) {
9610 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9611 break;
9612 }
9613 for (i = 0; i < ndim; i++)
9614 if (AD_LWBD(ad1, i) != AD_LWBD(ad2, i) ||
9615 AD_UPBD(ad1, i) != AD_UPBD(ad2, i))
9616 break;
9617 if (i < ndim) {
9618 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9619 break;
9620 }
9621 error(119, 2, gbl.lineno, SYMNAME(sptr), CNULL);
9622 } else if (stype1 != ST_UNKNOWN && stype1 != ST_IDENT &&
9623 stype1 != ST_VAR) {
9624 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
9625 break;
9626 }
9627 DTY(dtype + 1) = DTYPEG(sptr);
9628 } else if (IS_INTRINSIC(stype1) &&
9629 (entity_attr.exist & ET_B(ET_INTRINSIC)) == 0) {
9630 /* Changing intrinsic symbol to IDENT in COMMON */
9631 if (IN_MODULE_SPEC || entity_attr.exist || sem.interface) {
9632 if ((sptr = newsym(sptr)) == 0)
9633 /* Symbol frozen as an intrinsic, ignore in COMMON */
9634 break;
9635 SST_SYMP(LHS, sptr);
9636 /* Cause STYPE and DTYPE to change AFTER fixing dtype */
9637 stype1 = ST_UNKNOWN;
9638 dtype = DTYPEG(sptr);
9639 dtypeset = 1;
9640 }
9641 }
9642 /*
9643 * The symbol's stype and data type can only be changed if
9644 * it is new or if the type is changing from an identifier or
9645 * structure to an array. The latter can occur because of the
9646 * separation of type/record declarations from DIMENSION/COMMON
9647 * statements. If the symbol is a record, its stype can change
9648 * only if it's an identifier; note, that its dtype will be
9649 * set (and checked) by the semantic actions for record.
9650 */
9651 if (stype1 == ST_UNKNOWN ||
9652 (stype == ST_ARRAY && (stype1 == ST_IDENT || stype1 == ST_VAR))) {
9653 if (in_entity_typdcl)
9654 STYPEP(sptr, ST_IDENT); /* stype will be filled in later*/
9655 /* ...else stype will be set by the actions for <combined> */
9656
9657 if (!dtypeset)
9658 dtype = sem.gdtype;
9659 if (dtype > 0)
9660 DTYPEP(sptr, dtype);
9661 if (stype == ST_ARRAY) {
9662 if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) {
9663 if (AD_ASSUMSHP(ad))
9664 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9665 if (SCG(sptr) != SC_DUMMY)
9666 ALLOCP(sptr, 1);
9667 } else if (AD_ASSUMSZ(ad)) {
9668 if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
9669 SCG(sptr) != SC_BASED)
9670 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9671 ASUMSZP(sptr, 1);
9672 SEQP(sptr, 1);
9673 }
9674 if (AD_ADJARR(ad)) {
9675 ADJARRP(sptr, 1);
9676 if (SCG(sptr) != SC_NONE && SCG(sptr) != SC_DUMMY &&
9677 SCG(sptr) != SC_BASED)
9678 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9679 else {
9680 /*
9681 * mark the adjustable array if the declaration
9682 * occurs after an ENTRY statement.
9683 */
9684 if (entry_seen)
9685 AFTENTP(sptr, 1);
9686 }
9687 } else if (!(entity_attr.exist &
9689 AD_DEFER(ad)) {
9690 if (SCG(sptr) == SC_CMBLK)
9691 error(43, 3, gbl.lineno, "deferred shape array", SYMNAME(sptr));
9692 if (SCG(sptr) == SC_DUMMY) {
9694 ASSUMSHPP(sptr, 1);
9695 if (sem.arrdim.assumedrank) {
9696 ASSUMRANKP(sptr, 1);
9697 }
9698 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9699 SDSCS1P(sptr, 1);
9700 } else {
9701 if (AD_ASSUMSHP(ad)) {
9702 /* this is an error if it isn't a dummy; the
9703 * declaration could occur before its entry, so
9704 * the check needs to be performed in semfin.
9705 */
9706 ASSUMSHPP(sptr, 1);
9707 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9708 SDSCS1P(sptr, 1);
9709 }
9710 ALLOCP(sptr, 1);
9712 }
9713 }
9714 }
9715 } else if (stype == ST_ARRAY) {
9716 if (stype1 == ST_ENTRY) {
9717 if (FVALG(sptr)) {
9718#if DEBUG
9719 interr("semant1: trying to set data type of ST_ENTRY", sptr, 3);
9720#endif
9721 sptr = FVALG(sptr);
9722 } else {
9723 error(43, 3, gbl.lineno, "subprogram or entry", SYMNAME(sptr));
9724 sptr = insert_sym(sptr);
9725 }
9726 }
9727 if (RESULTG(sptr)) {
9728 assert(dtypeset, "semant: dtype was not set (2)", dtype, 3);
9729 DTYPEP(sptr, dtype);
9730 if ((entity_attr.exist & ET_B(ET_POINTER)) || POINTERG(sptr)) {
9731 if (!AD_DEFER(ad) || AD_ASSUMSHP(ad))
9732 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
9733 } else if (AD_ASSUMSZ(ad)) {
9734 ASUMSZP(sptr, 1);
9735 SEQP(sptr, 1);
9736 } else if (AD_ADJARR(ad))
9737 ADJARRP(sptr, 1);
9738 else if (AD_DEFER(ad)) {
9740 ASSUMSHPP(sptr, 1);
9741 if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))
9742 SDSCS1P(sptr, 1);
9743 AD_ASSUMSHP(ad) = 1;
9744 }
9746 }
9747 }
9748 }
9749 if (RESULTG(sptr) && STYPEG(sptr) != ST_ENTRY) {
9750 /* set the type for the entry point as well */
9752 }
9753
9754 /* store gdtype, gty so that we can retrieve later to get
9755 * dtype for each declared variable, sem.gdtype an sem.gty
9756 * may get overwritten if variable is initialized with f2003
9757 * feature.
9758 */
9760 SST_GTYP(RHS(1), sem.gty);
9761
9762 break;
9763
9764 /* ------------------------------------------------------------------ */
9765 /*
9766 * <target list> ::= <target list> , <target> |
9767 */
9768 case TARGET_LIST1:
9769 break;
9770 /*
9771 * <target list> ::= <target>
9772 */
9773 case TARGET_LIST2:
9774 break;
9775
9776 /* ------------------------------------------------------------------ */
9777 /*
9778 * <target> ::= <dcl id>
9779 */
9780 case TARGET1:
9781 TARGETP(SST_SYMG(RHS(1)), 1);
9782 break;
9783
9784 /* ------------------------------------------------------------------ */
9785 /*
9786 * <interface> ::= <begininterface> |
9787 */
9788 case INTERFACE1:
9790 break;
9791 /*
9792 * <interface> ::= <begininterface> <generic spec>
9793 */
9794 case INTERFACE2:
9797 error(155, 3, gbl.lineno, "A generic specifier cannot be present in an",
9798 "ABSTRACT INTERFACE");
9799 }
9800 break;
9801
9802 /* ------------------------------------------------------------------ */
9803 /*
9804 * <begininterface> ::= <pgm> INTERFACE |
9805 */
9806 case BEGININTERFACE1:
9807 i = 0;
9808 goto begininterf;
9809 /*
9810 * <begininterface> ::= <pgm> ABSTRACT INTERFACE
9811 */
9812 case BEGININTERFACE2:
9813 i = 1;
9814 begininterf:
9816 error(155, 3, gbl.lineno,
9817 "Interface-block may not appear in a"
9818 " module after the CONTAINS statement unless it is inside"
9819 " a module subprogram",
9820 CNULL);
9821 }
9823 sem.interf_size + 2);
9830 sem.interface++;
9831 break;
9832
9833 /* ------------------------------------------------------------------ */
9834 /*
9835 * <generic spec> ::= <generic name> |
9836 */
9837 case GENERIC_SPEC1:
9838 if (scn.stmtyp != TK_ENDINTERFACE) {
9839 /* If we have a previously defined symbol with
9840 * same name as a generic type bound procedure, delay declaring
9841 * the generic type bound procedure until we process the entire
9842 * module (see queue_tbp() function, flag == 3 case for the
9843 * call to declsym).
9844 */
9845 int oldsptr;
9846 sptr = (int)SST_SYMG(RHS(1));
9847 oldsptr = sptr;
9848 if (STYPEG(sptr) == ST_TYPEDEF) {
9849 sptr = insert_sym(sptr); /* Overloaded type */
9850 }
9851 if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) {
9852 if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) {
9853 /* Type bound procedure and generic interface can co-exist */
9854 sptr = insert_sym(sptr);
9855 } else if (STYPEG(sptr) && STYPEG(sptr) != ST_USERGENERIC) {
9856 sptr = insert_sym(sptr);
9857 } else if (STYPEG(sptr) == ST_USERGENERIC && IS_TBP(sptr)) {
9858 sptr = insert_sym(sptr);
9859 }
9860 sptr = declsym(sptr, ST_USERGENERIC, FALSE);
9861 if (STYPEG(oldsptr) != ST_TYPEDEF) {
9862 /* Check for the case where we overload the
9863 * type-name with a binding-name in a type bound procedure.
9864 */
9865 int oldsptr2 = oldsptr;
9866 for (; STYPEG(oldsptr2) == ST_ALIAS; oldsptr2 = SYMLKG(oldsptr2))
9867 ;
9868 if (STYPEG(oldsptr2) == ST_PROC && CLASSG(oldsptr2) &&
9869 VTOFFG(oldsptr2)) {
9870 oldsptr2 = findByNameStypeScope(SYMNAME(oldsptr2), ST_TYPEDEF,
9871 SCOPEG(oldsptr2));
9872 }
9873 if (STYPEG(oldsptr2) == ST_TYPEDEF)
9874 oldsptr = oldsptr2;
9875 }
9876 if (STYPEG(oldsptr) == ST_TYPEDEF) {
9877 GTYPEP(sptr, oldsptr); /* Store overloaded type */
9878 } else {
9879 /* Check for overloaded type in scope */
9880 oldsptr =
9881 findByNameStypeScope(SYMNAME(oldsptr), ST_TYPEDEF, SCOPEG(sptr));
9882 if (oldsptr)
9883 GTYPEP(sptr, oldsptr);
9884 }
9885 }
9886 if (SCOPEG(sptr) != stb.curr_scope) {
9887 int oldsptr = sptr;
9888 sptr = insert_sym(sptr);
9889 STYPEP(sptr, ST_USERGENERIC);
9890 SCOPEP(sptr, stb.curr_scope);
9891 copy_specifics(oldsptr, sptr);
9892 IGNOREP(oldsptr, TRUE);
9893 }
9894 EXPSTP(sptr, 1);
9896 }
9897 /*else
9898 * SST_SYMP(LHS, SST_SYMG(RHS(1)));
9899 */
9900 break;
9901 /*
9902 * <generic spec> ::= OPERATOR ( <operator> )
9903 */
9904 case GENERIC_SPEC2:
9905 if (scn.stmtyp != TK_ENDINTERFACE) {
9908 } else {
9909 SST_SYMP(LHS, SST_LSYMG(RHS(3)));
9910 }
9911 break;
9912 /*
9913 * <generic spec> ::= ASSIGNMENT ( = )
9914 */
9915 case GENERIC_SPEC3:
9916 if (scn.stmtyp != TK_ENDINTERFACE) {
9920 } else {
9922 SST_SYMP(LHS, sptr);
9923 }
9924 break;
9925
9926 /* ------------------------------------------------------------------ */
9927 /*
9928 * <generic name> ::= <ident> |
9929 */
9930 case GENERIC_NAME1:
9931 break;
9932 /*
9933 * <generic name> ::= OPERATOR |
9934 */
9935 case GENERIC_NAME2:
9936 sptr = getsymbol("operator");
9937 SST_SYMP(LHS, sptr);
9938 break;
9939 /*
9940 * <generic name> ::= ASSIGNMENT
9941 */
9942 case GENERIC_NAME3:
9943 sptr = getsymbol("assignment");
9944 SST_SYMP(LHS, sptr);
9945 break;
9946
9947 /*
9948 * <generic name> ::= <ident> ( <ident> )
9949 */
9950 case GENERIC_NAME4:
9952 if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "read") == 0) {
9953 if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) {
9954 sem.defined_io_type = 1;
9955 } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) {
9956 sem.defined_io_type = 2;
9957 } else {
9958 error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) "
9959 "must follow defined READ",
9960 CNULL);
9961 sem.defined_io_type = 0;
9962 }
9963 } else if (strcmp(SYMNAME(SST_SYMG(RHS(1))), "write") == 0) {
9964 if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "formatted") == 0) {
9965 sem.defined_io_type = 3;
9966 } else if (strcmp(SYMNAME(SST_SYMG(RHS(3))), "unformatted") == 0) {
9967 sem.defined_io_type = 4;
9968 } else {
9969 error(155, 3, gbl.lineno, "(FORMATTED) or (UNFORMATTED) "
9970 "follow defined WRITE",
9971 CNULL);
9972 sem.defined_io_type = 0;
9973 }
9974 } else {
9975 error(155, 3, gbl.lineno, "Invalid generic specification -",
9976 SYMNAME(SST_SYMG(RHS(1))));
9977 sem.defined_io_type = 0;
9978 }
9979 if (i && sem.defined_io_type && i != sem.defined_io_type) {
9980 char *name_cpy;
9981 name_cpy = getitem(0,
9982 strlen(SYMNAME(SST_SYMG(RHS(1)))) +
9983 strlen(SYMNAME(SST_SYMG(RHS(3)))) + 1);
9984 sprintf(name_cpy, "%s(%s)", SYMNAME(SST_SYMG(RHS(1))),
9985 SYMNAME(SST_SYMG(RHS(3))));
9986 error(155, 3, gbl.lineno,
9987 "Generic name for INTERFACE statement "
9988 "does not match generic name for END INTERFACE ",
9989 name_cpy);
9990 } else if (!i && sem.defined_io_type) {
9991 sptr = getsymf(".%s", SYMNAME(SST_SYMG(RHS(1))));
9992 IGNOREP(sptr, TRUE);
9993 SST_SYMP(LHS, sptr);
9994 }
9995 break;
9996
9997 /* ------------------------------------------------------------------ */
9998 /*
9999 * <operator> ::= <intrinsic op> |
10000 */
10001 case OPERATOR1:
10002 if (scn.stmtyp != TK_ENDINTERFACE)
10003 sptr1 = get_intrinsic_opr(SST_OPTYPEG(RHS(1)), SST_IDG(RHS(1)));
10004 else
10006 sptr = block_local_sym(sptr1);
10007 STYPEP(sptr, STYPEG(sptr1));
10008 SST_IDP(LHS, 1);
10009 SST_LSYMP(LHS, sptr);
10010 break;
10011 /*
10012 * <operator> ::= . <ident> .
10013 */
10014 case OPERATOR2:
10016 STYPEP(sptr, STYPEG(SST_SYMG(RHS(2))));
10017 if (!sem.generic_tbp || !STYPEG(sptr) || SCOPEG(sptr) != stb.curr_scope) {
10018 if (STYPEG(sptr) == ST_PROC && VTOFFG(sptr) && !sem.generic_tbp) {
10019 /* Type bound procedure and generic operator can co-exist */
10020 sptr = insert_sym(sptr);
10021 }
10022 sptr = declsym(sptr, ST_OPERATOR, FALSE);
10023 }
10024 SST_IDP(LHS, 1);
10025 SST_LSYMP(LHS, sptr);
10026 if (scn.stmtyp == TK_INTERFACE) {
10027 const char *anm;
10028 anm = NULL;
10029 if (strcmp(SYMNAME(sptr), "x") == 0)
10030 anm = ".x.";
10031 else if (strcmp(SYMNAME(sptr), "xor") == 0)
10032 anm = ".xor.";
10033 else if (strcmp(SYMNAME(sptr), "o") == 0)
10034 anm = ".o.";
10035 else if (strcmp(SYMNAME(sptr), "n") == 0)
10036 anm = ".n.";
10037 if (anm) {
10038 error(155, 1, gbl.lineno,
10039 "Predefined intrinsic operator loses intrinsic property -", anm);
10040 }
10041 }
10042 break;
10043 /*
10044 * <operator> ::= <defined op>
10045 */
10046 case OPERATOR3:
10048 STYPEP(sptr, STYPEG(SST_SYMG(RHS(1))));
10049 SST_IDP(LHS, 1);
10050 SST_LSYMP(LHS, sptr);
10051 break;
10052
10053 /* ------------------------------------------------------------------ */
10054 /*
10055 * <intrinsic op> ::= <addop> |
10056 */
10057 case INTRINSIC_OP1:
10058 SST_IDP(LHS, 0);
10059 SST_LSYMP(LHS, 3); /* unary and binary */
10060 break;
10061 /*
10062 * <intrinsic op> ::= <mult op> |
10063 */
10064 case INTRINSIC_OP2:
10065 SST_IDP(LHS, 0);
10066 SST_LSYMP(LHS, 2); /* binary */
10067 break;
10068 /*
10069 * <intrinsic op> ::= ** |
10070 */
10071 case INTRINSIC_OP3:
10072 SST_IDP(LHS, 0);
10074 SST_LSYMP(LHS, 2); /* binary */
10075 break;
10076 /*
10077 * <intrinsic op> ::= <n eqv op> |
10078 */
10079 case INTRINSIC_OP4:
10080 break;
10081 /*
10082 * <intrinsic op> ::= .OR. |
10083 */
10084 case INTRINSIC_OP5:
10085 SST_IDP(LHS, 0);
10087 SST_LSYMP(LHS, 2); /* binary */
10088 break;
10089 /*
10090 * <intrinsic op> ::= .O. |
10091 */
10092 case INTRINSIC_OP6:
10093 SST_IDP(LHS, TK_ORX);
10095 SST_LSYMP(LHS, 2); /* binary */
10096 break;
10097 /*
10098 * <intrinsic op> ::= .AND. |
10099 */
10100 case INTRINSIC_OP7:
10101 SST_IDP(LHS, 0);
10103 SST_LSYMP(LHS, 2); /* binary */
10104 break;
10105 /*
10106 * <intrinsic op> ::= .NOT. |
10107 */
10108 case INTRINSIC_OP8:
10109 SST_IDP(LHS, 0);
10111 SST_LSYMP(LHS, 1); /* unary */
10112 break;
10113 /*
10114 * <intrinsic op> ::= .N. |
10115 */
10116 case INTRINSIC_OP9:
10117 SST_IDP(LHS, TK_NOTX);
10119 SST_LSYMP(LHS, 1); /* unary */
10120 break;
10121 /*
10122 * <intrinsic op> ::= <relop> |
10123 */
10124 case INTRINSIC_OP10:
10125 SST_IDP(LHS, 0);
10126 SST_LSYMP(LHS, 2); /* binary */
10127 break;
10128 /*
10129 * <intrinsic op> ::= '//'
10130 */
10131 case INTRINSIC_OP11:
10132 SST_IDP(LHS, 0);
10134 SST_LSYMP(LHS, 2); /* binary */
10135 break;
10136
10137 /* ------------------------------------------------------------------ */
10138 /*
10139 * <n eqv op> ::= .EQV. |
10140 */
10141 case N_EQV_OP1:
10142 SST_IDP(LHS, 0);
10144 SST_LSYMP(LHS, 2); /* binary */
10145 break;
10146 /*
10147 * <n eqv op> ::= .NEQV. |
10148 */
10149 case N_EQV_OP2:
10150 SST_IDP(LHS, 0);
10152 SST_LSYMP(LHS, 2); /* binary */
10153 break;
10154 /*
10155 * <n eqv op> ::= .X. |
10156 */
10157 case N_EQV_OP3:
10158 SST_IDP(LHS, TK_XORX);
10160 SST_LSYMP(LHS, 2); /* binary */
10161 break;
10162 /*
10163 * <n eqv op> ::= .XOR.
10164 */
10165 case N_EQV_OP4:
10166 SST_IDP(LHS, TK_XOR);
10168 SST_LSYMP(LHS, 2); /* binary */
10169 break;
10170
10171 /* ------------------------------------------------------------------ */
10172 /*
10173 * <end interface> ::= ENDINTERFACE |
10174 */
10175 case END_INTERFACE1:
10176 rhstop = 1;
10177 goto end_interface_shared;
10178 /*
10179 * <end interface> ::= ENDINTERFACE <generic spec>
10180 */
10181 case END_INTERFACE2:
10182 rhstop = 2;
10183 end_interface_shared:
10184 if (sem.interface == 0) {
10185 error(302, 3, gbl.lineno, "INTERFACE", CNULL);
10186 SST_ASTP(LHS, 0);
10187 break;
10188 }
10189 if (gbl.currsub) {
10190 error(303, 2, gbl.lineno, SYMNAME(gbl.currsub), CNULL);
10193 }
10194 sem.interface--;
10197 if (sptr)
10199 else if ((sptr = sem.interf_base[sem.interface].operator))
10203 }
10204 if (sptr && rhstop == 2 && !sem.defined_io_type) {
10205 sptr1 = SST_SYMG(RHS(2));
10206 if (strcmp(SYMNAME(sptr), SYMNAME(sptr1)))
10207 error(309, 3, gbl.lineno, SYMNAME(sptr1), CNULL);
10208 }
10209 sem.defined_io_type = 0;
10210 break;
10211 /*
10212 * <module procedure stmt> ::= MODULE PROCEDURE <ident list> |
10213 * MODULE PROCEDURE :: <ident list>
10214 */
10215 case MODULE_PROCEDURE_STMT1:
10216 rhstop = 3;
10217 goto module_procedure_stmt;
10218 case MODULE_PROCEDURE_STMT2:
10219 rhstop = 4;
10220module_procedure_stmt:
10221 if (IN_MODULE &&
10222 !sem.interface &&
10223 (itemp = SST_BEGG(RHS(rhstop))) != ITEM_END &&
10224 itemp->next == ITEM_END) {
10225 /* MODULE PROCEDURE <id> - begin separate module subprogram */
10226 sptr = itemp->t.sptr;
10227
10228 /* C1548: checking MODULE prefix for subprograms that were
10229 declared as separate module procedures */
10230 if (!sem.interface &&
10231 !SEPARATEMPG(sptr) && !SEPARATEMPG(ref_ident(sptr))) {
10232 error(1056, ERR_Severe, gbl.lineno, NULL, NULL);
10233 DCLDP(sptr, true);
10234 }
10235
10236 gbl.currsub = instantiate_interface(sptr);
10238 gbl.rutype = FVALG(sptr) > NOSYM ? RU_FUNC : RU_SUBR;
10242 SST_ASTP(LHS, 0);
10243 break;
10244 }
10245 gnr = sem.interf_base[sem.interface - 1].generic;
10246 if (gnr == 0) {
10248 if (gnr == 0) {
10249 error(195, 3, gbl.lineno,
10250 "- MODULE PROCEDURE requires a generic INTERFACE", CNULL);
10251 break;
10252 }
10253 }
10254 count = 0;
10255 for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) {
10256 sptr = itemp->t.sptr;
10257 /* Temporarily open the interface scope. */
10259 if (!IN_MODULE) {
10260 sptr = refsym(sptr, OC_OTHER);
10261 if (STYPEG(sptr) != ST_PROC)
10262 error(195, 3, gbl.lineno, "- Unable to access module procedure",
10263 CNULL);
10264 if (ENCLFUNCG(sptr) == 0 || STYPEG(ENCLFUNCG(sptr)) != ST_MODULE) {
10265 error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10266 }
10267 } else {
10268 if (STYPEG(sptr) == ST_PROC && !sem.which_pass && !INMODULEG(sptr)) {
10269 error(454, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10270 }
10271 sptr = declsym(sptr, ST_MODPROC, FALSE);
10272 if (SYMLKG(sptr) == NOSYM)
10273 SYMLKP(sptr, 0);
10274 /* rescope modproc to 'module' scope */
10275 SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr);
10276 i = add_symitem(gnr, SYMIG(sptr));
10277 SYMIP(sptr, i);
10278 }
10279 /* Reclose the interface scope. */
10281 add_overload(gnr, sptr);
10282 if (STYPEG(SCOPEG(sptr)) == ST_MODULE) {
10283 /* make sure we include module name when generating
10284 * the symbol name.
10285 */
10286 INMODULEP(sptr, 1);
10287 }
10288 if (bind_attr.altname && (++count > 1))
10289 error(280, 2, gbl.lineno, "BIND: allowed only in module", 0);
10290 if (bind_attr.exist != -1) {
10292 }
10293 }
10294 bind_attr.exist = -1;
10295 bind_attr.altname = 0;
10296 break;
10297 /*
10298 * <procedure stmt> ::= PROCEDURE <ident list> |
10299 * PROCEDURE :: <ident list>
10300 */
10301 case PROCEDURE_STMT1:
10302 rhstop = 2;
10303 goto procedure_stmt;
10304 case PROCEDURE_STMT2:
10305 rhstop = 3;
10306procedure_stmt:
10307 if (sem.interface == 0) {
10308 error(155, 3, gbl.lineno, "PROCEDURE must appear in an INTERFACE", CNULL);
10309 break;
10310 }
10311 gnr = sem.interf_base[sem.interface - 1].generic;
10312 if (gnr == 0) {
10314 if (gnr == 0) {
10315 error(195, 3, gbl.lineno, "- PROCEDURE requires a generic INTERFACE",
10316 CNULL);
10317 break;
10318 }
10319 }
10320 count = 0;
10321 for (itemp = SST_BEGG(RHS(rhstop)); itemp != ITEM_END; itemp = itemp->next) {
10322 sptr = itemp->t.sptr;
10323 /* Temporarily open the interface scope. */
10325 sptr = refsym(sptr, OC_OTHER);
10326 if (STYPEG(sptr) != ST_PROC) {
10327 if (STYPEG(sptr) == ST_USERGENERIC) {
10328 sptr = insert_sym(sptr);
10329 }
10330 sptr = declsym(sptr, ST_PROC, FALSE);
10331 if (SYMLKG(sptr) == NOSYM)
10332 SYMLKP(sptr, 0);
10333 /* rescope proc to 'host' scope */
10334 SCOPEP(sptr, sem.scope_stack[sem.scope_level - 1].sptr);
10335 i = add_symitem(gnr, SYMIG(sptr));
10336 SYMIP(sptr, i);
10337 }
10338 /* Reclose the interface scope. */
10340 add_overload(gnr, sptr);
10341 }
10342 bind_attr.exist = -1;
10343 bind_attr.altname = 0;
10344 break;
10345
10346 /* ------------------------------------------------------------------ */
10347 /*
10348 * <use> ::= <get module> |
10349 */
10350 case USE1:
10351 add_use_stmt();
10352 break;
10353 /*
10354 * <use> ::= <get module> , <rename list> |
10355 */
10356 case USE2:
10357 break;
10358 /*
10359 * <use> ::= <get module> , <id name> : <only list> |
10360 */
10361 case USE3:
10362 /* fall thru */
10363 /*
10364 * <use> ::= <get module> , <id name> :
10365 */
10366 case USE4:
10367 np = scn.id.name + SST_CVALG(RHS(3));
10368 if (sem_strcmp(np, "only") != 0)
10369 error(34, 3, gbl.lineno, np, CNULL);
10370 break;
10371
10372 /* ------------------------------------------------------------------ */
10373 /*
10374 *
10375 * <get module> ::= , <module nature> :: <id> |
10376 */
10377 case GET_MODULE2:
10378
10379 sptr = SST_SYMG(RHS(4));
10380
10381 /* Undo context sensitive scanner confusion. This is a
10382 use statement, even though it contains a TK_INTRINSIC token
10383 This allows us to move into PHASE_USE.
10384 */
10385 if ((scn.stmtyp == TK_INTRINSIC) || (scn.stmtyp == TK_NON_INTRINSIC))
10386 scn.stmtyp = TK_USE;
10387
10388 /* check and enable ISO_C_BINDING INTRINSICS HERE? */
10389 if (SST_IDG(RHS(2))) {
10390/* use, intrinsic :: the only one we support is
10391 iso_c_binding
10392*/
10393
10394 } else {
10395 if (strcmp(SYMNAME(sptr), "iso_c_binding") == 0)
10396 error(4, 3, gbl.lineno, "invalid non-intrinsic module", SYMNAME(sptr));
10397 }
10398 goto common_module;
10399 break;
10400 /*
10401 * <get module> ::= :: <id>
10402 */
10403 case GET_MODULE3:
10404 sptr = SST_SYMG(RHS(2));
10405 goto common_module;
10406 break;
10407 /*
10408 * <get module> ::= <id> |
10409 */
10410 case GET_MODULE1:
10411 sptr = SST_SYMG(RHS(1));
10412 common_module:
10413 sem.use_seen = 1;
10415 if (XBIT(68, 0x1)) {
10416 /* Append "_la" to the names of some modules. */
10417 static const char *names[] = {"ieee_exceptions", "ieee_arithmetic",
10418 "cudafor", "openacc",
10419 "accel_lib", NULL};
10420 int j;
10421 for (j = 0; names[j]; ++j) {
10422 if (strcmp(SYMNAME(sptr), names[j]) == 0) {
10423 sptr = getsymf("%s", SYMNAME(sptr));
10424 break;
10425 }
10426 }
10427 }
10428 if (IN_MODULE && strcmp(SYMNAME(sem.mod_sym), SYMNAME(sptr)) == 0) {
10429 error(4, 3, gbl.lineno, "MODULE cannot contain USE of itself -",
10430 SYMNAME(sptr));
10431 break;
10432 }
10433 if (sptr >= stb.firstusym && STYPEG(sptr) != ST_UNKNOWN &&
10434 STYPEG(sptr) != ST_MODULE) {
10435 int nsptr;
10436 /* see if this is really an error, or just an overloaded symbol */
10437 nsptr = sym_in_scope(sptr, stb.ovclass[ST_MODULE], NULL, NULL, 0);
10438 if (nsptr > 0 && (nsptr < stb.firstusym || STYPEG(nsptr) == ST_UNKNOWN ||
10439 STYPEG(nsptr) == ST_MODULE)) {
10440 sptr = nsptr;
10441 } else {
10442 sptr = insert_sym(sptr);
10443 }
10444 }
10446 break;
10447
10448 /* ------------------------------------------------------------------ */
10449 /*
10450 * <module nature> ::= INTRINSIC |
10451 */
10452 case MODULE_NATURE1:
10453 SST_IDP(LHS, 1);
10454 break;
10455 /*
10456 * <module nature> ::= NON_INTRINSIC
10457 */
10458 case MODULE_NATURE2:
10459 SST_IDP(LHS, 0);
10460 break;
10461
10462 /* ------------------------------------------------------------------ */
10463 /*
10464 * <rename list> ::= <rename list> , <rename> |
10465 */
10466 case RENAME_LIST1:
10467 break;
10468 /*
10469 * <rename list> ::= <rename>
10470 */
10471 case RENAME_LIST2:
10472 break;
10473
10474 /* ------------------------------------------------------------------ */
10475 /*
10476 * <rename> ::= <ident> '=>' <ident> |
10477 */
10478 case RENAME1:
10479 add_use_stmt();
10480 sptr = sptr1 = SST_SYMG(RHS(3));
10481 if (test_scope(sptr) == -1) {
10482 // If symbol not in scope search for an in-scope symbol with same name.
10483 for (sptr1 = first_hash(sptr); sptr1 > NOSYM; sptr1 = HASHLKG(sptr1)) {
10484 if (sptr1 == sptr || NMPTRG(sptr) != NMPTRG(sptr1))
10485 continue;
10486 if (test_scope(sptr1) != -1) {
10487 sptr = sptr1;
10488 break; // Found it.
10489 }
10490 }
10491 }
10492 sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0);
10493 SST_SYMP(RHS(3), sptr);
10494 break;
10495 /*
10496 * <rename> ::= <id name> ( <rename operator> ) '=>' <id name> ( <rename
10497 *operator> )
10498 */
10499 case RENAME2:
10500 add_use_stmt();
10501 np = scn.id.name + SST_CVALG(RHS(1));
10502 if (sem_strcmp(np, "operator") == 0) {
10503 np = scn.id.name + SST_CVALG(RHS(6));
10504 if (sem_strcmp(np, "operator")) {
10505 error(34, 3, gbl.lineno, np, CNULL);
10506 break;
10507 }
10508 } else {
10509 error(34, 3, gbl.lineno, np, CNULL);
10510 break;
10511 }
10512 /* local (RHS(3)) => global (RHS(8)) */
10513 sptr = add_use_rename(SST_SYMG(RHS(3)), SST_SYMG(RHS(8)), 1);
10514 break;
10515
10516 /* ------------------------------------------------------------------ */
10517 /*
10518 * <rename operator> ::= . <ident> . |
10519 */
10520 case RENAME_OPERATOR1:
10521 SST_SYMP(LHS, SST_SYMG(RHS(2)));
10522 break;
10523 /*
10524 * <rename operator> ::= <defined op>
10525 */
10526 case RENAME_OPERATOR2:
10527 break;
10528
10529 /* ------------------------------------------------------------------ */
10530 /*
10531 * <only list> ::= <only list> , <only> |
10532 */
10533 case ONLY_LIST1:
10534 break;
10535 /*
10536 * <only list> ::= <only>
10537 */
10538 case ONLY_LIST2:
10539 break;
10540
10541 /* ------------------------------------------------------------------ */
10542 /*
10543 * <only> ::= <ident> |
10544 */
10545 case ONLY1:
10546 sptr = SST_SYMG(RHS(1));
10547 sptr = add_use_rename(0, sptr, 0);
10548 SST_SYMP(RHS(1), sptr);
10549 break;
10550 /*
10551 * <only> ::= <ident> '=>' <ident> |
10552 */
10553 case ONLY2:
10554 sptr = SST_SYMG(RHS(3));
10555 sptr = add_use_rename((int)SST_SYMG(RHS(1)), sptr, 0);
10556 SST_SYMP(RHS(3), sptr);
10557 break;
10558 /*
10559 * <only> ::= <id name> ( <only operator> ) |
10560 */
10561 case ONLY3:
10562 np = scn.id.name + SST_CVALG(RHS(1));
10563 if (sem_strcmp(np, "operator") == 0) {
10564 sptr = add_use_rename(0, SST_SYMG(RHS(3)), 1);
10565 SST_SYMP(RHS(3), sptr);
10566 } else
10567 error(34, 3, gbl.lineno, np, CNULL);
10568 break;
10569 /*
10570 * <only> ::= <id name> ( = )
10571 */
10572 case ONLY4:
10573 np = scn.id.name + SST_CVALG(RHS(1));
10574 if (sem_strcmp(np, "assignment") == 0) {
10576 add_use_rename(0, sptr, 1);
10577 } else
10578 error(34, 3, gbl.lineno, np, CNULL);
10579 break;
10580 /*
10581 * <only> ::= <id name> ( <only operator> ) '=>' <id name> ( <only operator
10582 * > )
10583 */
10584 case ONLY5:
10585 np = scn.id.name + SST_CVALG(RHS(1));
10586 if (sem_strcmp(np, "operator") == 0) {
10587 np = scn.id.name + SST_CVALG(RHS(6));
10588 if (sem_strcmp(np, "operator")) {
10589 error(34, 3, gbl.lineno, np, CNULL);
10590 break;
10591 }
10592 } else {
10593 error(34, 3, gbl.lineno, np, CNULL);
10594 break;
10595 }
10596 sptr = SST_SYMG(RHS(3));
10597 if (STYPEG(sptr) == ST_OPERATOR && INKINDG(sptr)) {
10598 error(34, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10599 break;
10600 }
10601 sptr = SST_SYMG(RHS(8));
10602 if (STYPEG(sptr) == ST_OPERATOR && INKINDG(sptr)) {
10603 error(34, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10604 break;
10605 }
10606 /* local (RHS(3)) => global (RHS(8)) */
10608 break;
10609
10610 /* ------------------------------------------------------------------ */
10611 /*
10612 * <only operator> ::= <intrinsic op> |
10613 */
10614 case ONLY_OPERATOR1:
10616 SST_SYMP(LHS, sptr);
10617 break;
10618 /*
10619 * <only operator> ::= . <ident> . |
10620 */
10621 case ONLY_OPERATOR2:
10622 SST_SYMP(LHS, SST_SYMG(RHS(2)));
10623 break;
10624 /*
10625 * <only operator> ::= <defined op>
10626 */
10627 case ONLY_OPERATOR3:
10628 break;
10629
10630 /* ------------------------------------------------------------------ */
10631 /*
10632 * <tp list> ::= <tp list> , <tp item> |
10633 */
10634 case TP_LIST1:
10635 rhstop = 3;
10636 goto add_tp_to_list;
10637 /*
10638 * <tp list> ::= <tp item>
10639 */
10640 case TP_LIST2:
10641 rhstop = 1;
10642 add_tp_to_list:
10643 itemp = (ITEM *)getitem(0, sizeof(ITEM));
10644 itemp->next = ITEM_END;
10645 itemp->t.sptr = SST_SYMG(RHS(rhstop));
10646 if (rhstop == 1)
10647 /* adding first item to list */
10648 SST_BEGP(LHS, itemp);
10649 else
10650 /* adding subsequent items to list */
10651 SST_ENDG(RHS(1))->next = itemp;
10652 SST_ENDP(LHS, itemp);
10653 break;
10654
10655 /* ------------------------------------------------------------------ */
10656 /*
10657 * <tp item> ::= <common> |
10658 */
10659 case TP_ITEM1:
10660 break;
10661 /*
10662 * <tp item> ::= <ident>
10663 */
10664 case TP_ITEM2:
10665 sptr = refsym(SST_SYMG(RHS(1)), OC_OTHER);
10666 SST_SYMP(LHS, sptr);
10667 break;
10668
10669 /* ------------------------------------------------------------------ */
10670 /*
10671 * <dec declaration> ::= ATTRIBUTES <msattr list> :: <cmn ident list> |
10672 */
10673 case DEC_DECLARATION1:
10674 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
10675 int da_bitv;
10676 sptr = itemp->t.sptr;
10677 if (sptr == 0)
10678 continue;
10679 if (STYPEG(sptr) != ST_CMBLK)
10680 sptr = refsym_inscope(sptr, OC_OTHER);
10681 da_type = 0;
10682 for (da_bitv = dec_attr.exist; da_bitv; da_bitv >>= 1, da_type++) {
10683 if ((da_bitv & 1) == 0)
10684 continue;
10685 switch (da_type) {
10686 case DA_ALIAS:
10687
10688#if defined(TARGET_WIN)
10689 /* silently disallow ALIAS of winmain : it conflicts
10690 with our crt0.obj glue
10691 */
10692 if (strcmp(SYMNAME(sptr), "winmain") == 0)
10693 break;
10694#endif
10695 ALTNAMEP(sptr, dec_attr.altname);
10696 goto global_attrs;
10697 case DA_C:
10698 CFUNCP(sptr, 1);
10699 STDCALLP(sptr, 1); /* args must be passed by value */
10700 if (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY) {
10701 MSCALLP(sptr, 0);
10702 }
10703 goto global_attrs;
10704 case DA_STDCALL:
10705 STDCALLP(sptr, 1);
10706#ifdef CREFP
10707 CREFP(sptr, 0);
10708 MSCALLP(sptr, 1);
10709#endif
10710 goto global_attrs;
10711 case DA_REFERENCE:
10712 if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC))
10713 ss = sptr;
10714 else
10715 ss = gbl.currsub;
10716 PASSBYVALP(sptr, 0);
10717 PASSBYREFP(sptr, 1);
10718#ifdef CREFP
10719 if (CFUNCG(sptr)) {
10720 MSCALLP(sptr, 0);
10721 CREFP(sptr, 1);
10722 }
10723#endif
10724 goto global_attrs;
10725
10726 case DA_VALUE:
10727 if ((STYPEG(sptr) == ST_ENTRY) || (STYPEG(sptr) == ST_PROC))
10728 ss = sptr;
10729 else
10730 ss = gbl.currsub;
10731 PASSBYVALP(sptr, 1);
10732 PASSBYREFP(sptr, 0);
10733 goto global_attrs;
10734
10735 case DA_DLLEXPORT:
10736 if (IN_MODULE && sem.interface == 0 && STYPEG(sptr) != ST_CMBLK) {
10738 if (sptr == gbl.currmod)
10739 break;
10740 } else {
10742 }
10743 goto global_attrs;
10744 case DA_DLLIMPORT:
10746 goto global_attrs;
10747 case DA_DECORATE:
10748 DECORATEP(sptr, 1);
10749 goto global_attrs;
10750 case DA_NOMIXEDSLA:
10751#ifdef CREFP
10752 NOMIXEDSTRLENP(sptr, 1);
10753#endif
10754 /* fall thru */
10755 global_attrs:
10756 switch (STYPEG(sptr)) {
10757 case ST_CMBLK:
10758 case ST_ENTRY:
10759 case ST_PROC:
10760 case ST_UNKNOWN: /* allow undeclared identifiers */
10761 break;
10762 case ST_IDENT:
10763 case ST_VAR:
10764 case ST_ARRAY:
10765 case ST_STRUCT:
10766 if (da_type == DA_DLLEXPORT) {
10767 if (IN_MODULE && sem.interface == 0) {
10768 if ((SCG(sptr) == SC_CMBLK && !HCCSYMG(CMBLKG(sptr))) ||
10769 SCOPEG(sptr) != gbl.currmod) {
10770 error(84, 3, gbl.lineno, SYMNAME(sptr),
10771 "- ATTRIBUTES items must be global");
10772 }
10773 break;
10774 }
10775 } else if ((da_type == DA_VALUE) || (da_type == DA_REFERENCE)) {
10776 break;
10777 }
10779 default:
10780 error(84, 3, gbl.lineno, SYMNAME(sptr),
10781 "- must be defined for ATTRIBUTES");
10782 }
10783 break;
10784 default:
10785 break;
10786 }
10787 }
10788 }
10789 dec_attr.exist = 0;
10790 break;
10791 /*
10792 * <dec declaration> ::= ALIAS <ident> , <alt name>
10793 */
10794 case DEC_DECLARATION2:
10795 /*
10796 * <dec declaration> ::= ALIAS <ident> : <alt name>
10797 */
10798 case DEC_DECLARATION3:
10799 sptr = refsym_inscope((int)SST_SYMG(RHS(2)), OC_OTHER);
10800 ALTNAMEP(sptr, SST_SYMG(RHS(4)));
10801 break;
10802
10803 /* ------------------------------------------------------------------ */
10804 /*
10805 * <msattr list> ::= <msattr list> , <msattr> |
10806 */
10807 case MSATTR_LIST1:
10808 /* fall thru */
10809 /*
10810 * <msattr list> ::= <msattr>
10811 */
10812 case MSATTR_LIST2:
10813 if (da_type == -1)
10814 break;
10815 if (dec_attr.exist & DA_B(da_type))
10816 error(134, 3, gbl.lineno, "- duplicate", da[da_type].name);
10817 else if (dec_attr.exist & da[da_type].no)
10818 error(134, 3, gbl.lineno, "- conflict with", da[da_type].name);
10819 else
10820 dec_attr.exist |= DA_B(da_type);
10821 break;
10822
10823 /* ------------------------------------------------------------------ */
10824 /*
10825 * <msattr> ::= <id name> |
10826 */
10827 case MSATTR1:
10828 da_type = -1;
10829 np = scn.id.name + SST_CVALG(RHS(1));
10830 if (strcmp(np, "alias") == 0) {
10831 error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10832 } else if (strcmp(np, "c") == 0)
10833 da_type = DA_C;
10834 else if (strcmp(np, "stdcall") == 0)
10835 da_type = DA_STDCALL;
10836 else if (sem_strcmp(np, "dllexport") == 0)
10837 da_type = DA_DLLEXPORT;
10838 else if (sem_strcmp(np, "dllimport") == 0)
10839 da_type = DA_DLLIMPORT;
10840 else if (sem_strcmp(np, "value") == 0)
10841 da_type = DA_VALUE;
10842 else if (sem_strcmp(np, "reference") == 0)
10843 da_type = DA_REFERENCE;
10844 else if (sem_strcmp(np, "decorate") == 0)
10845 da_type = DA_DECORATE;
10846 else if (sem_strcmp(np, "nomixed_str_len_arg") == 0)
10847 da_type = DA_NOMIXEDSLA;
10848 else
10849 error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10850 break;
10851 /*
10852 * <msattr> ::= <id name> : <alt name>
10853 */
10854 case MSATTR2:
10855 da_type = -1;
10856 np = scn.id.name + SST_CVALG(RHS(1));
10857 if (strcmp(np, "alias") == 0) {
10858 da_type = DA_ALIAS;
10860 } else
10861 error(155, 2, gbl.lineno, "Unrecognized directive: ATTRIBUTES", np);
10862 break;
10863
10864 /* ------------------------------------------------------------------ */
10865 /*
10866 * <alt name> ::= <quoted string> |
10867 */
10868 case ALT_NAME1:
10869 break;
10870 /*
10871 * <alt name> ::= <id name>
10872 */
10873 case ALT_NAME2:
10874 /* NEED TO UPCASE the name */
10875 for (np = scn.id.name + SST_CVALG(RHS(1)); (i = *np); np++) {
10876 if (i >= 'a' && i <= 'z')
10877 *np = i + ('A' - 'a');
10878 }
10879 np = scn.id.name + SST_CVALG(RHS(1));
10880 sptr = getstring(np, strlen(np));
10881 SST_SYMP(LHS, sptr);
10882 break;
10883
10884 /* ------------------------------------------------------------------ */
10885 /*
10886 * <cmn ident list> ::= <cmn ident list> , <cmn ident> |
10887 */
10888 case CMN_IDENT_LIST1:
10889 rhstop = 3;
10890 goto add_cmn_to_list;
10891 /*
10892 * <cmn ident list> ::= <cmn ident>
10893 */
10894 case CMN_IDENT_LIST2:
10895 rhstop = 1;
10896 add_cmn_to_list:
10897 itemp = (ITEM *)getitem(0, sizeof(ITEM));
10898 itemp->next = ITEM_END;
10899 itemp->t.sptr = SST_SYMG(RHS(rhstop));
10900 if (rhstop == 1)
10901 /* adding first item to list */
10902 SST_BEGP(LHS, itemp);
10903 else
10904 /* adding subsequent items to list */
10905 SST_ENDG(RHS(1))->next = itemp;
10906 SST_ENDP(LHS, itemp);
10907 break;
10908
10909 /* ------------------------------------------------------------------ */
10910 /*
10911 * <cmn ident> ::= <common> |
10912 */
10913 case CMN_IDENT1:
10914 sptr = SST_SYMG(RHS(1));
10915 if (sem.which_pass && CMEMFG(sptr) == 0)
10916 error(38, 3, gbl.lineno, SYMNAME(sptr), CNULL);
10917 break;
10918 /*
10919 * <cmn ident> ::= <ident>
10920 */
10921 case CMN_IDENT2:
10922 sptr = SST_SYMG(RHS(1));
10923 if (STYPEG(sptr) == ST_CMBLK) {
10924 sptr = refsym(sptr, OC_OTHER);
10925 SST_SYMP(LHS, sptr);
10926 }
10927 break;
10928
10929 /* ------------------------------------------------------------------ */
10930 /*
10931 * <pragma declaration> ::= <nis> LOCAL ( <ident list> ) |
10932 */
10933 case PRAGMA_DECLARATION1:
10934 break;
10935 /*
10936 * <pragma declaration> ::= <nis> <ignore tkr> |
10937 */
10938 case PRAGMA_DECLARATION2:
10939 if (!sem.interface && !(IN_MODULE && gbl.currsub)) {
10940 error(155, 3, gbl.lineno,
10941 "IGNORE_TKR can only appear in an interface body"
10942 " or a module procedure",
10943 CNULL);
10944 }
10945 break;
10946 /*
10947 * <pragma declaration> ::= <nis> DEFAULTKIND <dflt> |
10948 */
10949 case PRAGMA_DECLARATION3:
10950 break;
10951 /*
10952 * <pragma declaration> ::= <nis> MOVEDESC <id name>
10953 */
10954 case PRAGMA_DECLARATION4:
10955#if defined(MVDESCP)
10956 np = scn.id.name + SST_CVALG(RHS(3));
10957 if (gbl.currsub && sem_strcmp(np, SYMNAME(gbl.currsub)) == 0) {
10958 MVDESCP(gbl.currsub, 1);
10959 }
10960#endif
10961 break;
10962
10963 /* ------------------------------------------------------------------ */
10964 /*
10965 * <ignore tkr> ::= IGNORE_TKR |
10966 */
10967 case IGNORE_TKR1:
10968 if (sem.interface || (IN_MODULE && gbl.currsub)) {
10969 /* must be in interface -- if not, an error will be reported* later */
10970 count = PARAMCTG(gbl.currsub);
10971 i = DPDSCG(gbl.currsub);
10972 while (count--) {
10973 sptr = *(aux.dpdsc_base + i + count);
10974 /* IGNORE_TKR_ALL includes all of the IGNORE_ values plus
10975 * an indicater except for IGNORE_C
10976 */
10977 IGNORE_TKRP(sptr, IGNORE_TKR_ALL);
10978 }
10979 }
10980 break;
10981 /*
10982 * <ignore tkr> ::= IGNORE_TKR <tkr id list>
10983 */
10984 case IGNORE_TKR2:
10985 break;
10986
10987 /* ------------------------------------------------------------------ */
10988 /*
10989 * <tkr id list> ::= <tkr id list> , <tkr id> |
10990 */
10991 case TKR_ID_LIST1:
10992 break;
10993 /*
10994 * <tkr id list> ::= <tkr id>
10995 */
10996 case TKR_ID_LIST2:
10997 break;
10998
10999 /* ------------------------------------------------------------------ */
11000 /*
11001 * <tkr id> ::= <tkr spec> <ident>
11002 */
11003 case TKR_ID1:
11004 sptr = refsym(SST_SYMG(RHS(2)), OC_OTHER);
11005 if (sem.interface || (IN_MODULE && gbl.currsub)) {
11006 /* must be in interface -- if not, an error will be reported* later */
11007 if (SCG(sptr) == SC_DUMMY)
11008 IGNORE_TKRP(sptr, IGNORE_TKRG(sptr) | SST_CVALG(RHS(1)));
11009 else
11010 error(134, 3, gbl.lineno,
11011 "- IGNORE_TKR specified for nondummy argument", SYMNAME(sptr));
11012 }
11013 break;
11014
11015 /* ------------------------------------------------------------------ */
11016 /*
11017 * <tkr spec> ::= |
11018 */
11019 case TKR_SPEC1:
11020 /* NOT IGNORE_C */
11022 break;
11023 /*
11024 * <tkr spec> ::= ( <id name> )
11025 */
11026 case TKR_SPEC2:
11027 np = scn.id.name + SST_CVALG(RHS(2));
11028 conval = 0;
11029 count = strlen(np);
11030 for (i = 0; i < count; i++) {
11031 switch (np[i]) {
11032 case 't':
11033 case 'T':
11034 conval |= IGNORE_T;
11035 break;
11036 case 'k':
11037 case 'K':
11038 conval |= IGNORE_K;
11039 break;
11040 case 'r':
11041 case 'R':
11042 conval |= IGNORE_R;
11043 break;
11044 case 'a':
11045 case 'A':
11046 conval |= IGNORE_TKR_ALL;
11047 break;
11048 case 'd':
11049 case 'D':
11050 conval |= IGNORE_D;
11051 break;
11052 case 'm':
11053 case 'M':
11054 conval |= IGNORE_M;
11055 break;
11056 case 'c':
11057 case 'C':
11058 conval |= IGNORE_C;
11059 break;
11060 default:
11061 error(155, 3, gbl.lineno, "Illegal IGNORE_TKR specifier", CNULL);
11062 conval = 0;
11063 goto end_tkr_spec;
11064 }
11065 }
11066 end_tkr_spec:
11067 SST_CVALP(LHS, conval);
11068 break;
11069
11070 /* ------------------------------------------------------------------ */
11071 /*
11072 * <dflt> ::= |
11073 */
11074 case DFLT1:
11075#ifdef DFLTP
11076 if (gbl.currsub) {
11077 DFLTP(gbl.currsub, 1);
11078 }
11079#endif
11080 break;
11081 /*
11082 * <dflt> ::= ( <ident list> )
11083 */
11084 case DFLT2:
11085#ifdef DFLTP
11086 for (itemp = SST_BEGG(RHS(2)); itemp != ITEM_END; itemp = itemp->next) {
11087 sptr = getocsym(itemp->t.sptr, OC_OTHER, FALSE);
11088 if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) {
11089 DFLTP(sptr, 1);
11090 }
11091 }
11092#endif
11093 break;
11094
11095 /* ------------------------------------------------------------------ */
11096 /*
11097 * <import> ::= IMPORT |
11098 */
11099 case IMPORT1:
11100 if (!sem.interface) {
11101 error(155, 3, gbl.lineno, "IMPORT can only appear in an interface body",
11102 CNULL);
11103 } else {
11105 }
11106 break;
11107
11108 /* ------------------------------------------------------------------ */
11109 /*
11110 * <opt import> ::= |
11111 */
11112 case OPT_IMPORT1:
11113 if (sem.interface) {
11114 /*
11115 * The current context is:
11116 * interface
11117 * ...
11118 * subroutine/function ...
11119 * IMPORT
11120 * end subroutine/function
11121 * ...
11122 * end interface
11123 *
11124 * There should be three scope entries corresponding to this
11125 * context:
11126 *
11127 * scope_level-2 : SCOPE_INTERFACE
11128 * scope_level-1 : SCOPE_NORMAL
11129 * scope_level : SCOPE_SUBPROGRAM
11130 *
11131 * For IMPORT without a list, open the SCOPE_NORMAL to make host
11132 * symbols visible.
11133 */
11134 for (i = sem.scope_level - 1; i >= 4; i--) {
11135 if (sem.scope_stack[i].kind == SCOPE_NORMAL) {
11137 break;
11138 }
11139 }
11140 }
11141 break;
11142 /*
11143 * <opt import> ::= <opt attr> <import name list>
11144 */
11145 case OPT_IMPORT2:
11146 break;
11147
11148 /* ------------------------------------------------------------------ */
11149 /*
11150 * <import name list> ::= <import name list> , <import name> |
11151 */
11152 case IMPORT_NAME_LIST1:
11153 break;
11154 /*
11155 * <import name list> ::= <import name>
11156 */
11157 case IMPORT_NAME_LIST2:
11158 break;
11159
11160 /* ------------------------------------------------------------------ */
11161 /*
11162 * <import name> ::= <ident>
11163 */
11164 case IMPORT_NAME1:
11165 if (sem.interface) {
11166 /*
11167 * The current context is:
11168 * interface
11169 * ...
11170 * subroutine/function ...
11171 * IMPORT xxxx
11172 * end subroutine/function
11173 * ...
11174 * end interface
11175 *
11176 * There should be three scope entries corresponding to this
11177 * context:
11178 *
11179 * scope_level-2 : SCOPE_INTERFACE
11180 * scope_level-1 : SCOPE_NORMAL
11181 * scope_level : SCOPE_SUBPROGRAM
11182 *
11183 * add the host-associcated symbols to the import list of
11184 * the SCOPE_NORMAL entry.
11185 */
11187 }
11188 break;
11189
11190 /* ------------------------------------------------------------------ */
11191 /*
11192 * <procedure declaration> ::= <procedure> <opt attr> <proc dcl list>
11193 */
11194 case PROCEDURE_DECLARATION1:
11195 entity_attr.exist = 0;
11196 bind_attr.exist = -1;
11197 bind_attr.altname = 0;
11198 break;
11199
11200 /* ------------------------------------------------------------------ */
11201 /*
11202 * <procedure> ::= PROCEDURE ( <proc interf> ) <opt proc attr>
11203 */
11204 case PROCEDURE1:
11205 break;
11206
11207 /* ------------------------------------------------------------------ */
11208 /*
11209 * <proc interf> ::= |
11210 */
11211 case PROC_INTERF1:
11212 sem.gdtype = -1;
11213 proc_interf_sptr = 0;
11214 break;
11215 /*
11216 * <proc interf> ::= <id> |
11217 */
11218 case PROC_INTERF2:
11219 proc_interf_sptr = resolve_sym_aliases(SST_SYMG(RHS(1)));
11220 break;
11221 /*
11222 * <proc interf> ::= <data type>
11223 */
11224 case PROC_INTERF3:
11225 proc_interf_sptr = 0;
11226 break;
11227
11228 /* ------------------------------------------------------------------ */
11229 /*
11230 * <opt proc attr> ::= |
11231 */
11232 case OPT_PROC_ATTR1:
11233 break;
11234 /*
11235 * <opt proc attr> ::= , <proc attr list>
11236 */
11237 case OPT_PROC_ATTR2:
11238 if ((entity_attr.exist & ET_B(ET_PROTECTED)) &&
11239 !(entity_attr.exist & ET_B(ET_POINTER)))
11240 error(134, 3, gbl.lineno, et[ET_PROTECTED].name, "for procedure");
11241 break;
11242
11243 /* ------------------------------------------------------------------ */
11244 /*
11245 * <proc attr list> ::= <proc attr list> , <proc attr> |
11246 */
11247 case PROC_ATTR_LIST1:
11248 /*
11249 * <proc attr list> ::= <proc attr>
11250 */
11251 case PROC_ATTR_LIST2:
11252 if (entity_attr.exist & ET_B(et_type))
11253 error(134, 3, gbl.lineno, "- duplicate", et[et_type].name);
11254 if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
11255 if (ET_B(et_type) &
11257 ET_B(ET_ACCESS))) {
11258 error(134, 3, gbl.lineno, et[et_type].name, "for procedure component");
11259 } else
11260 entity_attr.exist |= ET_B(et_type);
11261 } else {
11262 if (ET_B(et_type) &
11266 error(134, 3, gbl.lineno, et[et_type].name, "for procedure");
11267 else
11268 entity_attr.exist |= ET_B(et_type);
11269 }
11270 break;
11271
11272 /* ------------------------------------------------------------------ */
11273 /*
11274 * <proc attr> ::= <access spec> |
11275 */
11276 case PROC_ATTR1:
11277 et_type = ET_ACCESS;
11278 break;
11279 /*
11280 * <proc attr> ::= BIND <bind attr> |
11281 */
11282 case PROC_ATTR2:
11283 et_type = ET_BIND;
11284 break;
11285 /*
11286 * <proc attr> ::= <intent> |
11287 */
11288 case PROC_ATTR3:
11289 et_type = ET_INTENT;
11290 break;
11291 /*
11292 * <proc attr> ::= OPTIONAL |
11293 */
11294 case PROC_ATTR4:
11295 et_type = ET_OPTIONAL;
11296 break;
11297 /*
11298 * <proc attr> ::= POINTER |
11299 */
11300 case PROC_ATTR5:
11301 et_type = ET_POINTER;
11302 break;
11303 /*
11304 * <proc attr> ::= SAVE |
11305 */
11306 case PROC_ATTR6:
11307 et_type = ET_SAVE;
11308 break;
11309 /*
11310 * <proc attr> ::= PASS |
11311 */
11312 case PROC_ATTR7:
11313 et_type = ET_PASS;
11314 entity_attr.pass_arg = 0; /* PASS without argname */
11315 break;
11316 /*
11317 * <proc attr> ::= PASS ( <ident> ) |
11318 */
11319 case PROC_ATTR8:
11320 et_type = ET_PASS;
11321 entity_attr.pass_arg = SST_SYMG(RHS(3)); /* PASS with argname */
11322 break;
11323 /*
11324 * <proc attr> ::= NOPASS |
11325 */
11326 case PROC_ATTR9:
11327 et_type = ET_NOPASS;
11328 break;
11329 /*
11330 * <proc attr> ::= PROTECTED
11331 */
11332 case PROC_ATTR10:
11333 et_type = ET_PROTECTED;
11334 break;
11335
11336 /* ------------------------------------------------------------------ */
11337 /*
11338 * <proc dcl list> ::= <proc dcl list> , <proc dcl> |
11339 */
11340 case PROC_DCL_LIST1:
11341 break;
11342 /*
11343 * <proc dcl list> ::= <proc dcl>
11344 */
11345 case PROC_DCL_LIST2:
11346 break;
11347 /*
11348 * <proc dcl> ::= <ident> '=>' <id>
11349 */
11350 case PROC_DCL3:
11351 sptr = SST_SYMG(RHS(3));
11352 sem.proc_initializer = true;
11353 goto proc_dcl_init;
11354
11355
11356 /* ------------------------------------------------------------------ */
11357 /*
11358 * <proc dcl> ::= <ident> |
11359 */
11360 case PROC_DCL1:
11361 inited = FALSE;
11362 goto proc_dcl_shared;
11363 /*
11364 * <proc dcl> ::= <ident> '=>' <id> ( )
11365 */
11366 case PROC_DCL2:
11367 sptr = SST_SYMG(RHS(3));
11368 if (sptr <= NOSYM || strcmp(SYMNAME(sptr),"null") != 0) {
11369 errsev(87);
11370 }
11371proc_dcl_init:
11372 sptr = refsym(sptr, OC_OTHER);
11373 SST_SYMP(RHS(3), sptr);
11374 SST_IDP(RHS(3), S_IDENT);
11376 (void)mkvarref(RHS(3), ITEM_END);
11378 inited = TRUE;
11379
11380 proc_dcl_shared:
11381 sptr = SST_SYMG(RHS(1));
11382 {
11383 /* Hide, so we can modify attribute list without exposing it */
11384 int attr = entity_attr.exist;
11385 if (!POINTERG(sptr) && !(attr & ET_B(ET_POINTER)) &&
11386 proc_interf_sptr > NOSYM && SCG(sptr) != SC_DUMMY) {
11387 /* Check to see if we have a dummy argument with a name that overloads
11388 * another symbol name (such as a procedure name).
11389 */
11390 SPTR sym;
11392 while ((sym = get_next_hash_link(sptr, 2)) > NOSYM) {
11393 if (!POINTERG(sym) && SCG(sym) == SC_DUMMY &&
11394 SCOPEG(sym) == stb.curr_scope) {
11395 sptr = sym;
11396 break;
11397 }
11398 }
11399 }
11400 if (!POINTERG(sptr) && !(attr & ET_B(ET_POINTER)) &&
11401 proc_interf_sptr > NOSYM && SCG(sptr) == SC_DUMMY) {
11402 IS_PROC_DUMMYP(sptr, 1);
11403 }
11404 if (POINTERG(sptr)) {
11405 attr |= ET_B(ET_POINTER);
11406 }
11407 if (!IS_PROC_DUMMYG(sptr) && IS_INTERFACEG(proc_interf_sptr) &&
11408 !IS_PROC_PTR_IFACEG(proc_interf_sptr)) {
11409 /* Create a unique symbol for the interface so it does not conflict with
11410 * an external procedure symbol. For non-procedure dummy arguments,
11411 * we need a unique symbol for the interface in order to preserve
11412 * the interface flag (IS_PROC_PTR_IFACE). We need the interface flag in
11413 * the back-end so we properly generate the procedure descriptor
11414 * actual arguments on the call-site (when we call the procedure pointer).
11415 * This is only needed by the LLVM back-end because the bridge uses the
11416 * interface to generate the LLVM IR for the actual arguments.
11417 */
11418 char * buf;
11419 int len;
11420 SPTR sym;
11421
11422 /* First, let's see if we aleady have a unique interface symbol */
11423 len = strlen(SYMNAME(proc_interf_sptr)) + strlen("iface") + 1;
11424 buf = getitem(0, len);
11425 sprintf(buf,"%s$iface",SYMNAME(proc_interf_sptr));
11426 sym = findByNameStypeScope(buf, ST_PROC, 0);
11427 if (sym > NOSYM && !cmp_interfaces_strict(sym, proc_interf_sptr, 0)) {
11428 /* The interface is not compatible. We will now try to find one that
11429 * is compatible in the symbol table.
11430 */
11431 SPTR sym2 = sym;
11432 get_next_hash_link(sym2, 0);
11433 while ((sym2=get_next_hash_link(sym2, 1)) > NOSYM) {
11434 if (cmp_interfaces_strict(sym2, proc_interf_sptr, 0)) {
11435 break;
11436 }
11437 }
11438 sym = sym2;
11439 }
11440 if (sym <= NOSYM) {
11441 /* We don't yet have a unique interface symbol, so create it now */
11442 sym = get_next_sym(SYMNAME(proc_interf_sptr), "iface");
11443 /* Propagate flags from the original symbol to the new symbol */
11444 copy_sym_flags(sym, proc_interf_sptr);
11445 HCCSYMP(sym, 1);
11446 IS_PROC_PTR_IFACEP(sym, 1);
11447 }
11448 proc_interf_sptr = sym;
11449 }
11450 sptr = decl_procedure_sym(sptr, proc_interf_sptr, attr);
11451 sptr =
11452 setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access);
11453 }
11454
11455 /* Error while creating proc symbol */
11456 if (sptr == 0)
11457 break;
11458
11459 SST_SYMP(RHS(1), sptr);
11460
11461 stype = STYPEG(sptr);
11462
11463 if (inited) { /* check if symbol is data initialized */
11464 if (stype == ST_PROC) {
11465 error(114, 3, gbl.lineno, SYMNAME(SST_SYMG(RHS(1))), CNULL);
11466 goto proc_decl_end;
11467 }
11468 if (INSIDE_STRUCT && (STSK_ENT(0).type == 'd')) {
11471 SCP(sptr, SC_BASED);
11472 ast = SST_ASTG(RHS(3));
11473 if (A_TYPEG(ast) == A_FUNC) {
11475 }
11476 construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
11477 if (!SST_ACLG(RHS(3))) {
11478 goto proc_decl_end;
11479 }
11480
11481 ict = SST_ACLG(RHS(3));
11482 ict->sptr = sptr; /* field/component sptr */
11483 save_struct_init(ict);
11484 stsk = &STSK_ENT(0);
11485 if (stsk->ict_beg) {
11486 (stsk->ict_end)->next = SST_ACLG(RHS(3));
11487 stsk->ict_end = SST_ACLG(RHS(3));
11488 } else {
11489 stsk->ict_beg = SST_ACLG(RHS(3));
11490 stsk->ict_end = SST_ACLG(RHS(3));
11491 }
11492 } else {
11493 /* Data item (not TYPE component) initialization */
11494 /* have
11495 * ... :: <ptr> => NULL()
11496 * <ptr>$p, <ptr>$o, <ptr>$sd will be needed */
11499 ast = SST_ASTG(RHS(3));
11500 if (A_TYPEG(ast) == A_FUNC) {
11502 }
11503 construct_acl_for_sst(RHS(3), DTYPEG(SST_SYMG(RHS(1))));
11504 if (!SST_ACLG(RHS(3))) {
11505 goto proc_decl_end;
11506 }
11507 ast = mk_id(sptr);
11508 SST_ASTP(RHS(1), ast);
11509 SST_DTYPEP(RHS(1), DTYPEG(SST_SYMG(RHS(1))));
11510 SST_SHAPEP(RHS(1), 0);
11511 ivl = dinit_varref(RHS(1));
11512
11513 dinit(ivl, SST_ACLG(RHS(3)));
11514 }
11515 } else if (POINTERG(sptr)) {
11518 }
11519
11520 proc_decl_end:
11521
11522 if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_MEMBER &&
11523 RESULTG(sptr)) {
11524 /* set the type for the entry point as well */
11526 }
11528
11529 break;
11530
11531 /* ------------------------------------------------------------------ */
11532 /*
11533 * <type bound procedure> ::= <tprocedure> <opt attr> <binding name list>
11534 */
11535 case TYPE_BOUND_PROCEDURE1:
11536 dtype = /*sem.stag_dtype*/ stsk->dtype;
11537 if (SST_FIRSTG(RHS(1)) & 0x2) { /* nopass */
11538 queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_NOPASS);
11539 }
11540 if (SST_FIRSTG(RHS(1)) & 0x4) { /* non_overridable */
11542 }
11543 if (SST_FIRSTG(RHS(1)) & 0x8) { /* deferred */
11544 if (!ABSTRACTG(DTY(dtype + 3))) {
11545 error(155, 3, gbl.lineno,
11546 "Specifying a deferred type bound procedure in "
11547 "non-abstract type",
11548 SYMNAME(DTY(dtype + 3)));
11549 }
11550 if (!sem.tbp_interface) {
11551 error(155, 3, gbl.lineno,
11552 "Specifying a deferred type bound procedure without"
11553 " an interface-name in",
11554 SYMNAME(DTY(dtype + 3)));
11555 }
11557 }
11558 if (SST_FIRSTG(RHS(1)) & 0x10) { /* private */
11559 queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PRIVATE);
11560 } else if (SST_FIRSTG(RHS(1)) & 0x20) { /* public */
11561 queue_tbp(0, SST_SYMG(RHS(3)), 0, dtype, TBP_PUBLIC);
11562 }
11563 if (SST_FIRSTG(RHS(1)) & 0x1) {
11564 sptr = SST_LSYMG(RHS(1));
11565 if (sptr) { /* pass */
11567 if (STYPEG(sptr) != ST_IDENT || DTYPEG(sptr) != dtype) {
11568 sptr = insert_sym(sptr);
11569 sptr = declsym(sptr, ST_IDENT, TRUE);
11570 DTYPEP(sptr, dtype);
11571 SCP(sptr, SC_DUMMY);
11572 IGNOREP(sptr, TRUE);
11573 }
11575 }
11576 }
11577 sem.tbp_interface = 0;
11578 break;
11579
11580 /* ------------------------------------------------------------------ */
11581 /*
11582 * <tprocedure> ::= TPROCEDURE <opt interface name> <opt binding attr list>
11583 */
11584 case TPROCEDURE1:
11586 if (SST_FIRSTG(RHS(3)) & 0x1)
11587 SST_LSYMP(LHS, SST_LSYMG(RHS(3)));
11588 SST_ASTP(LHS, 0);
11589 break;
11590
11591 /* ------------------------------------------------------------------ */
11592 /*
11593 * <opt interface name> ::= |
11594 */
11595 case OPT_INTERFACE_NAME1:
11596 break;
11597 /*
11598 * <opt interface name> ::= ( <id> )
11599 */
11600 case OPT_INTERFACE_NAME2:
11602 dtype = /*sem.stag_dtype*/ stsk->dtype;
11604 break;
11605
11606 /* ------------------------------------------------------------------ */
11607 /*
11608 * <opt binding attr list> ::= |
11609 */
11610 case OPT_BINDING_ATTR_LIST1:
11611 SST_FIRSTP(LHS, 0);
11612 SST_LSYMP(LHS, 0);
11613 break;
11614 /*
11615 * <opt binding attr list> ::= , <binding attr list>
11616 */
11617 case OPT_BINDING_ATTR_LIST2:
11619 if (SST_FIRSTG(RHS(2)) & 0x1) {
11620 SST_LSYMP(LHS, SST_LSYMG(RHS(2)));
11621 }
11622 break;
11623
11624 /* ------------------------------------------------------------------ */
11625 /*
11626 * <binding attr list> ::= <binding attr list> , <binding attr> |
11627 */
11628 case BINDING_ATTR_LIST1:
11629 switch (SST_FIRSTG(RHS(1)) & SST_FIRSTG(RHS(3))) {
11630 case 0x1:
11631 error(134, 3, gbl.lineno, "- duplicate", "PASS");
11632 break;
11633 case 0x2:
11634 error(134, 3, gbl.lineno, "- duplicate", "NOPASS");
11635 break;
11636 case 0x4:
11637 error(134, 3, gbl.lineno, "- duplicate", "NON_OVERRIDABLE");
11638 break;
11639 case 0x8:
11640 error(134, 3, gbl.lineno, "- duplicate", "DEFERRED");
11641 break;
11642 case 0x10:
11643 error(134, 3, gbl.lineno, "- duplicate", "PRIVATE");
11644 break;
11645 case 0x20:
11646 error(134, 3, gbl.lineno, "- duplicate", "PUBLIC");
11647 break;
11648 }
11649
11650 if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x1) &&
11651 ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x2)) {
11652
11653 error(155, 3, gbl.lineno, "PASS and NOPASS may not appear "
11654 "in same type bound procedure",
11655 CNULL);
11656 } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x4) &&
11657 ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x8)) {
11658 error(155, 3, gbl.lineno, "DEFERRED and NON_OVERRIDABLE "
11659 "may not appear in same type bound procedure",
11660 CNULL);
11661 } else if (((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x10) &&
11662 ((SST_FIRSTG(RHS(1)) | SST_FIRSTG(RHS(3))) & 0x20)) {
11663 error(155, 3, gbl.lineno, "PRIVATE and PUBLIC "
11664 "may not appear in same type bound procedure",
11665 CNULL);
11666 }
11667
11669
11670 if (SST_FIRSTG(RHS(3)) & 0x1 && SST_LSYMG(RHS(3)))
11671 SST_LSYMP(RHS(1), SST_LSYMG(RHS(3)));
11673 /*
11674 * <binding attr list> ::= <binding attr>
11675 */
11676 case BINDING_ATTR_LIST2:
11677 if (SST_FIRSTG(RHS(1)) & 0x1)
11678 SST_LSYMP(LHS, SST_LSYMG(RHS(1)));
11679 break;
11680
11681 /* ------------------------------------------------------------------ */
11682 /*
11683 * <binding attr> ::= <id name> |
11684 */
11685 case BINDING_ATTR1:
11686 /*
11687 * Not using keywords to enumerate the attributes; <id name> may be:
11688 * PASS NOPASS NON_OVERRIDABLE DEFERRED PRIVATE PUBLIC
11689 */
11690 SST_LSYMP(LHS, 0);
11691 np = scn.id.name + SST_CVALG(RHS(1));
11692 if (sem_strcmp(np, "pass") == 0) {
11693 SST_FIRSTP(LHS, 0x1);
11694 } else if (sem_strcmp(np, "nopass") == 0) {
11695 SST_FIRSTP(LHS, 0x2);
11696 } else if (sem_strcmp(np, "non_overridable") == 0) {
11697 SST_FIRSTP(LHS, 0x4);
11698 } else if (sem_strcmp(np, "deferred") == 0) {
11699 SST_FIRSTP(LHS, 0x8);
11700 } else if (sem_strcmp(np, "private") == 0) {
11701 SST_FIRSTP(LHS, 0x10);
11702 } else if (sem_strcmp(np, "public") == 0) {
11703 SST_FIRSTP(LHS, 0x20);
11704 } else {
11705 error(34, 3, gbl.lineno, np, CNULL);
11706 }
11707 break;
11708 /*
11709 * <binding attr> ::= <id name> ( <id> )
11710 */
11711 case BINDING_ATTR2:
11712 /*
11713 * Not using keywords to enumerate the attributes; this must be
11714 * PASS ( arg-name )
11715 */
11716 np = scn.id.name + SST_CVALG(RHS(1));
11717 if (sem_strcmp(np, "pass") == 0) {
11718 SST_FIRSTP(LHS, 0x1);
11719 SST_LSYMP(LHS, SST_SYMG(RHS(3)));
11720 } else {
11721 error(34, 3, gbl.lineno, np, CNULL);
11722 }
11723 break;
11724
11725 /* ------------------------------------------------------------------ */
11726 /*
11727 * <binding name list> ::= <binding name list> , <binding name> |
11728 */
11729 case BINDING_NAME_LIST1:
11730 break;
11731 /*
11732 * <binding name list> ::= <binding name>
11733 */
11734 case BINDING_NAME_LIST2:
11735 break;
11736
11737 /* ------------------------------------------------------------------ */
11738 /*
11739 * <binding name> ::= <id> |
11740 */
11741 case BINDING_NAME1:
11742 rhstop = 1;
11743 goto binding_name_common;
11744 /*
11745 * <binding name> ::= <id> '=>' <id>
11746 */
11747 case BINDING_NAME2: {
11748 SPTR tag, sptr3, sptr2, orig_sptr;
11749 char *name, *name_cpy, *name_cpy2;
11750 DTYPE parent;
11751 SPTR sym;
11752 int vtoff, len;
11753
11754 if (strcmp(SYMNAME(SST_SYMG(RHS(1))), SYMNAME(SST_SYMG(RHS(3)))) == 0) {
11755 rhstop = 1;
11756 } else {
11757 rhstop = 3;
11758 }
11759
11760 binding_name_common:
11761
11762 tag = DTY(stsk->dtype + 3);
11763 orig_sptr = sptr = SST_SYMG(RHS(1));
11764 if (sem.tbp_interface > NOSYM) {
11765 sptr2 = sem.tbp_interface;
11766 } else {
11767 sptr2 = refsym(SST_SYMG(RHS(rhstop)), OC_OTHER);
11768 }
11769
11770 if (SEPARATEMPG(sptr2))
11771 TBP_BOUND_TO_SMPP(sptr2, TRUE);
11772
11774 sptr = insert_sym(sptr);
11775 }
11776
11777 parent = DTYPEG(PARENTG(tag));
11778 vtoff = 0;
11779 for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) {
11780 if (is_tbp(sym)) {
11781 len = strlen(SYMNAME(BINDG(sym))) + 1;
11782 name_cpy = getitem(0, len);
11783 strcpy(name_cpy, SYMNAME(BINDG(sym)));
11784 name = strstr(name_cpy, "$tbp");
11785 if (name)
11786 *name = '\0';
11787 if (strcmp(name_cpy, SYMNAME(sptr)) == 0) {
11788 vtoff = VTOFFG(BINDG(sym));
11789 VTOFFP(sptr, vtoff);
11790 break;
11791 }
11792 }
11793 }
11794 if (rhstop == 1) {
11795 if (STYPEG(sptr2) && STYPEG(sptr2) != ST_PROC) {
11796 sptr2 = insert_sym(sptr2);
11797 }
11798 sptr = getsymf("%s$tbp", SYMNAME(sptr));
11799 if (STYPEG(sptr) > 0) {
11800 sptr = insert_sym(sptr);
11801 }
11802 }
11803
11804 if (TBPLNKG(sptr) && !eq_dtype2(TBPLNKG(sptr), stsk->dtype, 1)) {
11805 sptr3 = insert_sym(sptr);
11806 STYPEP(sptr3, STYPEG(sptr));
11807 IGNOREP(sptr3, IGNOREG(sptr));
11808 sptr = sptr3;
11809 parent = DTYPEG(PARENTG(tag));
11810 sym = DTY(parent + 1);
11811 vtoff = 0;
11812 for (sym = get_struct_members(parent); sym > NOSYM; sym = SYMLKG(sym)) {
11813 if (CCSYMG(sym) && BINDG(sym)) {
11814
11815 len = strlen(SYMNAME(BINDG(sym))) + 1;
11816 name_cpy = getitem(0, len);
11817 strcpy(name_cpy, SYMNAME(BINDG(sym)));
11818 name = strstr(name_cpy, "$tbp");
11819 if (name)
11820 *name = '\0';
11821
11822 len = strlen(SYMNAME(sptr)) + 1;
11823 name_cpy2 = getitem(0, len);
11824 strcpy(name_cpy2, SYMNAME(sptr));
11825 name = strstr(name_cpy2, "$tbp");
11826 if (name)
11827 *name = '\0';
11828
11829 if (strcmp(name_cpy, name_cpy2) == 0) {
11830 vtoff = VTOFFG(BINDG(sym));
11831 VTOFFP(sptr, vtoff);
11832 break;
11833 }
11834 }
11835 }
11836 }
11837 /* Ignore temporary binding name only if we're overloading
11838 * a binding name with a derived type name or if stype is 0.
11839 */
11840
11841 if (STYPEG(orig_sptr) != ST_PD && STYPEG(sptr) != ST_PROC) {
11842 /* when found a binding name has a parameter attribute, don't ignore it
11843 * as we need to export this sptr into a *.mod file.
11844 */
11845 if (STYPEG(orig_sptr) != ST_PARAM)
11846 IGNOREP(sptr, TRUE);
11847 sptr = insert_sym(sptr);
11848 sptr = declsym(sptr, ST_PROC, FALSE);
11849 IGNOREP(sptr, TRUE); /* Needed for overloading */
11850 }
11851
11852 if (vtoff) {
11853 VTOFFP(sptr, vtoff);
11854 }
11855
11856 if (!VTOFFG(tag) && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
11857 VTOFFP(tag, VTOFFG(PARENTG(tag))); /*initialize offset*/
11858 }
11859 if (!VTOFFG(sptr) && !VTOFFG(tag) &&
11860 (vtoff = get_vtoff(0, stsk->dtype)) > 0) {
11861 /* Set vtable offset based on dtype and its parents */
11862 VTOFFP(sptr, vtoff + 1);
11863 VTOFFP(tag, vtoff + 1);
11864 CLASSP(sptr, 1);
11865 }
11866 if (!VTOFFG(sptr)) {
11867 /* Give this type bound procedure (tbp) an offset by incrementing
11868 * the tag's offset count and storing it in the tbp's PARENT field.
11869 */
11870 VTOFFP(tag, VTOFFG(tag) + 1);
11871 VTOFFP(sptr, VTOFFG(tag));
11872 CLASSP(sptr, 1);
11873 }
11874
11875 /* keep track of pass object type in tbp by storing the "least extended"
11876 * type extension in TBPLNK field.
11877 */
11878 if (!TBPLNKG(sptr)) {
11879 TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype);
11880 } else if (eq_dtype2(/*DTYPEG*/ (TBPLNKG(sptr)),
11881 /*sem.stag_dtype*/ stsk->dtype, 1)) {
11882 TBPLNKP(sptr, /*sem.stag_dtype*/ stsk->dtype);
11883 }
11884 queue_tbp(sptr2, sptr, VTOFFG(sptr), /*sem.stag_dtype*/ stsk->dtype,
11885 (rhstop == 1) ? TBP_ADD_SIMPLE : TBP_ADD_IMPL);
11886
11887 /* If we pushed the binding name into the symbol table,
11888 * we might have to remove it now, as it might be masking
11889 * a previous name (e.g., a parameter).
11890 */
11891 if (!STYPEG(sptr) ||
11892 (orig_sptr > NOSYM &&
11893 HASHLKG(sptr) == orig_sptr &&
11894 STYPEG(orig_sptr))) {
11895 pop_sym(sptr);
11896 }
11897 } break;
11898 /* ------------------------------------------------------------------ */
11899 /*
11900 * <accel decl begin> ::=
11901 */
11902 case ACCEL_DECL_BEGIN1:
11903 parstuff_init();
11904 break;
11905 /* ------------------------------------------------------------------ */
11906 /*
11907 * <accel decl list> ::= <accel decl list> <opt comma> <accel decl attr> |
11908 */
11909 case ACCEL_DECL_LIST1:
11910 break;
11911 /*
11912 * <accel decl list> ::= <accel decl attr>
11913 */
11914 case ACCEL_DECL_LIST2:
11915 break;
11916 /* ------------------------------------------------------------------ */
11917 /*
11918 * <accel decl attr> ::= COPYIN ( <accel decl data list> ) |
11919 */
11920 case ACCEL_DECL_ATTR1:
11921 break;
11922 /*
11923 * <accel decl attr> ::= COPYOUT ( <accel decl data list> ) |
11924 */
11925 case ACCEL_DECL_ATTR2:
11926 break;
11927 /*
11928 * <accel decl attr> ::= LOCAL ( <accel decl data list> ) |
11929 */
11930 case ACCEL_DECL_ATTR3:
11931 break;
11932 /*
11933 * <accel decl attr> ::= COPY ( <accel decl data list> ) |
11934 */
11935 case ACCEL_DECL_ATTR4:
11936 break;
11937 /*
11938 * <accel decl attr> ::= MIRROR ( <accel mdecl data list> ) |
11939 */
11940 case ACCEL_DECL_ATTR5:
11941 break;
11942 /*
11943 * <accel decl attr> ::= REFLECTED ( <accel mdecl data list> ) |
11944 */
11945 case ACCEL_DECL_ATTR6:
11946 break;
11947 /*
11948 * <accel decl attr> ::= CREATE ( <accel decl data list> ) |
11949 */
11950 case ACCEL_DECL_ATTR7:
11951 break;
11952 /*
11953 * <accel decl attr> ::= PRESENT ( <accel decl data list> ) |
11954 */
11955 case ACCEL_DECL_ATTR8:
11956 break;
11957 /*
11958 * <accel decl attr> ::= PCOPY ( <accel decl data list> ) |
11959 */
11960 case ACCEL_DECL_ATTR9:
11961 break;
11962 /*
11963 * <accel decl attr> ::= PCOPYIN ( <accel decl data list> ) |
11964 */
11965 case ACCEL_DECL_ATTR10:
11966 break;
11967 /*
11968 * <accel decl attr> ::= PCOPYOUT ( <accel decl data list> ) |
11969 */
11970 case ACCEL_DECL_ATTR11:
11971 break;
11972 /*
11973 * <accel decl attr> ::= PLOCAL ( <accel decl data list> ) |
11974 */
11975 case ACCEL_DECL_ATTR12:
11976 break;
11977 /*
11978 * <accel decl attr> ::= PCREATE ( <accel decl data list> ) |
11979 */
11980 case ACCEL_DECL_ATTR13:
11981 break;
11982 /*
11983 * <accel decl attr> ::= DEVICEPTR ( <accel decl data list> ) |
11984 */
11985 case ACCEL_DECL_ATTR14:
11986 break;
11987 /*
11988 * <accel decl attr> ::= DEVICE_RESIDENT ( <accel decl data list> ) |
11989 */
11990 case ACCEL_DECL_ATTR15:
11991 break;
11992 /*
11993 * <accel decl attr> ::= LINK ( <accel decl data list> ) |
11994 */
11995 case ACCEL_DECL_ATTR16:
11996 break;
11997
11998 /* ------------------------------------------------------------------ */
11999 /*
12000 * <accel decl data list> ::= <accel decl data list> , <accel decl data> |
12001 */
12002 case ACCEL_DECL_DATA_LIST1:
12003 accel_decl_data_list1:
12004 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12005 itemp->next = ITEM_END;
12006 itemp->ast = SST_ASTG(RHS(3));
12007 SST_ENDG(RHS(1))->next = itemp;
12008 SST_ENDP(LHS, itemp);
12009 break;
12010 /*
12011 * <accel decl data list> ::= <accel decl data>
12012 */
12013 case ACCEL_DECL_DATA_LIST2:
12014 accel_decl_data_list2:
12015 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12016 itemp->next = ITEM_END;
12017 itemp->ast = SST_ASTG(RHS(1));
12018 SST_BEGP(LHS, itemp);
12019 SST_ENDP(LHS, itemp);
12020 break;
12021
12022 /* ------------------------------------------------------------------ */
12023 /*
12024 * <accel decl data> ::= <accel decl data name> ( <accel decl sub list> ) |
12025 */
12026 case ACCEL_DECL_DATA1:
12027 /*###*/
12028 accel_decl_data1:
12029 sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
12030 switch (STYPEG(sptr)) {
12031 case ST_ARRAY:
12032 itemp = SST_BEGG(RHS(3));
12033 (void)mkvarref(RHS(1), itemp);
12034 SST_PARENP(LHS, 0); /* ? */
12035 break;
12036 default:
12037 error(155, 3, gbl.lineno, "Unknown symbol used in data clause -",
12038 SYMNAME(sptr));
12039 break;
12040 }
12041 break;
12042 /*
12043 * <accel decl data> ::= <accel decl data name> |
12044 */
12045 /*###*/
12046 case ACCEL_DECL_DATA2:
12047 accel_decl_data2:
12048 sptr = refsym((int)SST_SYMG(RHS(1)), OC_OTHER);
12049 mkident(LHS);
12050 SST_SYMP(LHS, sptr);
12051 SST_DTYPEP(LHS, DTYPEG(sptr));
12053 break;
12054 /*
12055 * <accel decl data> ::= <constant> |
12056 */
12057 case ACCEL_DECL_DATA3:
12058 /*###*/
12059 break;
12060 /*
12061 * <accel decl data> ::= <common>
12062 */
12063 case ACCEL_DECL_DATA4:
12064 sptr = SST_SYMG(RHS(1));
12065 SST_SYMP(LHS, sptr);
12066 SST_DTYPEP(LHS, 0);
12068 break;
12069 /* ------------------------------------------------------------------ */
12070 /*
12071 * <accel mdecl data> ::= <accel mdecl data name> ( <accel decl sub list> )
12072 *|
12073 */
12074 case ACCEL_MDECL_DATA1:
12075 goto accel_decl_data1;
12076 /*
12077 * <accel mdecl data> ::= <accel mdecl data name>
12078 */
12079 case ACCEL_MDECL_DATA2:
12080 goto accel_decl_data2;
12081 /*
12082 * <accel mdecl data> ::= <constant>
12083 */
12084 case ACCEL_MDECL_DATA3:
12085 break;
12086
12087 /* ------------------------------------------------------------------ */
12088 /*
12089 * <accel mdecl data list> ::= <accel mdecl data list> , <accel mdecl data>
12090 *|
12091 */
12092 case ACCEL_MDECL_DATA_LIST1:
12093 goto accel_decl_data_list1;
12094 /*
12095 * <accel mdecl data list> ::= <accel mdecl data>
12096 */
12097 case ACCEL_MDECL_DATA_LIST2:
12098 goto accel_decl_data_list2;
12099
12100 /* ------------------------------------------------------------------ */
12101 /*
12102 * <accel decl sub list> ::= <accel decl sub list> , <accel decl sub> |
12103 */
12104 case ACCEL_DECL_SUB_LIST1:
12105 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12106 itemp->next = ITEM_END;
12107 itemp->t.stkp = SST_E1G(RHS(3));
12108 SST_ENDG(RHS(1))->next = itemp;
12109 SST_ENDP(LHS, itemp);
12110 break;
12111 /*
12112 * <accel decl sub list> ::= <accel decl sub>
12113 */
12114 case ACCEL_DECL_SUB_LIST2:
12115 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12116 itemp->next = ITEM_END;
12117 itemp->t.stkp = SST_E1G(RHS(1));
12118 SST_BEGP(LHS, itemp);
12119 SST_ENDP(LHS, itemp);
12120 break;
12121 /* ------------------------------------------------------------------ */
12122 /*
12123 * <generic type procedure> ::= GENERIC <opt gen access spec> ::
12124 * <generic binding>
12125 */
12126 case GENERIC_TYPE_PROCEDURE1:
12128 if (!sptr) {
12130 sem.generic_tbp = ST_OPERATOR;
12131 } else {
12132 sem.generic_tbp = ST_USERGENERIC;
12133 }
12134
12135 switch (SST_FIRSTG(RHS(2))) {
12136 case 0x10:
12137 i = TBP_CHECK_PRIVATE; /* private */
12138 break;
12139 case 0x20:
12140 i = TBP_CHECK_PUBLIC; /* public */
12141 break;
12142 case 0x0:
12143 default:
12145 }
12146 for (itemp = SST_BEGG(RHS(4)); itemp != ITEM_END; itemp = itemp->next) {
12147 int tag;
12148 dtype = stsk->dtype;
12149 tag = DTY(dtype + 3);
12150
12151 if (!VTOFFG(sptr)) {
12152 int vt = VTOFFG(tag);
12153 if (!vt && PARENTG(tag) && VTOFFG(PARENTG(tag))) {
12154 /* Seed the vtable offset field of derived type tag with its parent's
12155 * vtable offset. It will get updated in
12156 * <binding name> ::= <id> '=>' <id> production.
12157 */
12158 vt = VTOFFG(PARENTG(tag));
12159 VTOFFP(tag, vt);
12160 }
12161 /* Set offset of binding name to next offset. */
12162 VTOFFP(sptr, vt + 1);
12163 if (STYPEG(sptr) == ST_OPERATOR) {
12164/* Set CLASS flag so we can properly handle its
12165 * access in semfin.c do_access(). We don't set it for
12166 * ST_USERGENERIC here because a USERGENERIC can overload
12167 * a type name (including the type name of the type defining
12168 * the generic tbp).
12169 */
12170 CLASSP(sptr, 1);
12171 }
12172 }
12173 /* offset needs to be same as overloaded tbp */
12174 queue_tbp(itemp->t.sptr, sptr, VTOFFG(sptr), stsk->dtype, i);
12175 }
12176 sem.interface--;
12177 sem.generic_tbp = 0;
12178 sem.defined_io_type = 0;
12179 break;
12180
12181 /*
12182 * <opt gen access spec> ::= |
12183 */
12184 case OPT_GEN_ACCESS_SPEC1:
12185 SST_FIRSTP(LHS, 0x0);
12186 goto gen_access_spec_common;
12187 /*
12188 * <opt gen access spec> ::= , <gen access spec>
12189 */
12190 case OPT_GEN_ACCESS_SPEC2:
12192 gen_access_spec_common:
12193 sem.generic_tbp = 1;
12195 sem.interf_size + 2);
12201 sem.interface++;
12202 break;
12203
12204 /*
12205 * <gen access spec> ::= <id name>
12206 */
12207 case GEN_ACCESS_SPEC1:
12208 np = scn.id.name + SST_CVALG(RHS(1));
12209 sptr = getsymbol(np);
12210 if (strcmp(SYMNAME(sptr), "private") == 0)
12211 SST_FIRSTP(LHS, 0x10);
12212 else if (strcmp(SYMNAME(sptr), "public") == 0)
12213 SST_FIRSTP(LHS, 0x20);
12214 else
12215 error(155, 3, gbl.lineno, "Invalid access specifier in generic"
12216 " type bound procedure",
12217 CNULL);
12218 break;
12219
12220 /* ------------------------------------------------------------------ */
12221 /*
12222 * <accel decl sub> ::= <opt sub> : <opt sub> |
12223 */
12224 case ACCEL_DECL_SUB1:
12225 e1 = (SST *)getitem(sem.ssa_area, sizeof(SST));
12226 SST_IDP(e1, S_TRIPLE);
12227 SST_E1P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
12228 *(SST_E1G(e1)) = *RHS(1);
12229 SST_E2P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
12230 *(SST_E2G(e1)) = *RHS(3);
12231 SST_E3P(e1, (SST *)getitem(sem.ssa_area, sizeof(SST)));
12232 SST_IDP(SST_E3G(e1), S_NULL);
12233 SST_E1P(LHS, e1);
12234 SST_E2P(LHS, 0);
12235 break;
12236 /*
12237 * <accel decl sub> ::= <expression>
12238 */
12239 case ACCEL_DECL_SUB2:
12240 e1 = (SST *)getitem(sem.ssa_area, sizeof(SST));
12241 *e1 = *RHS(1);
12242 SST_E1P(LHS, e1);
12243 SST_E2P(LHS, 0);
12244 break;
12245
12246 /* ------------------------------------------------------------------ */
12247 /*
12248 * <accel routine list> ::= |
12249 */
12250 case ACCEL_ROUTINE_LIST1:
12251 break;
12252 /*
12253 * <accel routine list> ::= <accel routine list> <opt comma> GANG |
12254 */
12255 case ACCEL_ROUTINE_LIST2:
12256 break;
12257 /*
12258 * <accel routine list> ::= <accel routine list> <opt comma> WORKER |
12259 */
12260 case ACCEL_ROUTINE_LIST3:
12261 break;
12262 /*
12263 * <accel routine list> ::= <accel routine list> <opt comma> VECTOR |
12264 */
12265 case ACCEL_ROUTINE_LIST4:
12266 break;
12267 /*
12268 * <accel routine list> ::= <accel routine list> <opt comma> SEQ |
12269 */
12270 case ACCEL_ROUTINE_LIST5:
12271 break;
12272 /*
12273 * <accel routine list> ::= <accel routine list> <opt comma> NOHOST |
12274 */
12275 case ACCEL_ROUTINE_LIST6:
12276 break;
12277 /*
12278 * <accel routine list> ::= <accel routine list> <opt comma> BIND ( <ident>
12279 *) |
12280 */
12281 case ACCEL_ROUTINE_LIST7:
12282 break;
12283 /*
12284 * <accel routine list> ::= <accel routine list> <opt comma> BIND ( <quoted
12285 *string> ) |
12286 */
12287 case ACCEL_ROUTINE_LIST8:
12288 break;
12289 /*
12290 * <accel routine list> ::= <accel routine list> <opt comma> DEVICE_TYPE (
12291 *<devtype list> )
12292 */
12293 case ACCEL_ROUTINE_LIST9:
12294 break;
12295 /*
12296 * <accel routine list> ::= <accel routine list> <opt comma> GANG ( <ident>
12297 *: <expression> )
12298 */
12299 case ACCEL_ROUTINE_LIST10:
12300 break;
12301 /*
12302 * <accel routine list> ::= <accel routine list> <opt comma> EXCLUDE
12303 */
12304 case ACCEL_ROUTINE_LIST11:
12305 break;
12306
12307 /* ------------------------------------------------------------------ */
12308 /*
12309 * <devtype list> ::= <devtype list> , <devtype attr> |
12310 */
12311 case DEVTYPE_LIST1:
12312 break;
12313 /*
12314 * <devtype list> ::= <devtype attr>
12315 */
12316 case DEVTYPE_LIST2:
12317 break;
12318
12319 /* ------------------------------------------------------------------ */
12320 /*
12321 * <devtype attr> ::= * |
12322 */
12323 case DEVTYPE_ATTR1:
12324 break;
12325 /*
12326 * <devtype attr> ::= <ident>
12327 */
12328 case DEVTYPE_ATTR2:
12329 break;
12330
12331 /* ------------------------------------------------------------------ */
12332 /*
12333 * <generic binding> ::= <generic spec> '=>' <generic binding list>
12334 */
12335 case GENERIC_BINDING1:
12337 if (!sptr) {
12339 }
12340 TBPLNKP(sptr, stsk->dtype);
12341 SST_BEGP(LHS, SST_BEGG(RHS(3)));
12342 break;
12343
12344 /* ------------------------------------------------------------------ */
12345 /*
12346 * <generic binding name> ::= <id>
12347 */
12348 case GENERIC_BINDING_NAME1:
12349 break;
12350
12351 /* ------------------------------------------------------------------ */
12352 /*
12353 * <generic binding list> ::= <generic binding name> |
12354 */
12355 case GENERIC_BINDING_LIST1:
12356 rhstop = 1;
12357 goto shared_generic_binding;
12358 /*
12359 * <generic binding list> ::= <generic binding list>, <generic binding
12360 * name>
12361 */
12362 case GENERIC_BINDING_LIST2:
12363 rhstop = 3;
12364 shared_generic_binding:
12365 sptr = SST_SYMG(RHS(rhstop));
12366 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12367 itemp->next = ITEM_END;
12368 itemp->t.sptr = sptr;
12369 if (rhstop == 1)
12370 /* adding first item to list */
12371 SST_BEGP(LHS, itemp);
12372 else
12373 /* adding subsequent items to list */
12374 SST_ENDG(RHS(1))->next = itemp;
12375 SST_ENDP(LHS, itemp);
12376 break;
12377
12378 /* ------------------------------------------------------------------ */
12379 /*
12380 * <final subroutines> ::= FINAL <opt attr> <final list>
12381 */
12382 case FINAL_SUBROUTINES1:
12383 if (sem.type_mode < 2) {
12384 error(155, 3, gbl.lineno,
12385 "a FINAL subroutine statement can only appear"
12386 " within the type bound procedure part of a derived type",
12387 CNULL);
12388 }
12389 for (itemp = SST_BEGG(RHS(3)); itemp != ITEM_END; itemp = itemp->next) {
12390 dtype = stsk->dtype;
12391 sptr = itemp->t.sptr;
12393 /*queue_tbp(sptr, 0, 0, dtype, TBP_ADD_TO_DTYPE);*/
12394 }
12395 break;
12396 /* ------------------------------------------------------------------ */
12397 /*
12398 * <final list> ::= <final>
12399 */
12400 case FINAL_LIST2:
12401 rhstop = 1;
12402 goto shared_final_sub;
12403
12404 /* ------------------------------------------------------------------ */
12405 /*
12406 * <final list> ::= <final list> , <final> |
12407 */
12408 case FINAL_LIST1:
12409 rhstop = 3;
12410 shared_final_sub:
12411 sptr = SST_SYMG(RHS(rhstop));
12412 itemp = (ITEM *)getitem(0, sizeof(ITEM));
12413 itemp->next = ITEM_END;
12414 itemp->t.sptr = sptr;
12415 if (rhstop == 1)
12416 /* adding first item to list */
12417 SST_BEGP(LHS, itemp);
12418 else
12419 /* adding subsequent items to list */
12420 SST_ENDG(RHS(1))->next = itemp;
12421 SST_ENDP(LHS, itemp);
12422 break;
12423
12424 /* ------------------------------------------------------------------ */
12425 /*
12426 * <mp decl begin> ::=
12427 */
12428 case MP_DECL_BEGIN1:
12429 break;
12430
12431 /* ------------------------------------------------------------------ */
12432 /*
12433 * <mp decl> ::= <mp declaresimd> <declare simd> |
12434 */
12435 case MP_DECL1:
12436#ifdef OMP_OFFLOAD_LLVM
12437 if(flg.omptarget) {
12438 error(1200, ERR_Severe, gbl.lineno, "declare simd",
12439 NULL);
12440 }
12441#endif
12442 break;
12443 /*
12444 * <mp decl> ::= <declare target> <opt par list> |
12445 */
12446 case MP_DECL2:
12447#ifdef OMP_OFFLOAD_LLVM
12448 if(flg.omptarget) {
12449 error(1200, ERR_Severe, gbl.lineno, "declare target",
12450 NULL);
12451 }
12452#endif
12453 break;
12454 /*
12455 * <mp decl> ::= <declarered begin> <declare reduction>
12456 */
12457 case MP_DECL3:
12458 break;
12459
12460 /* ------------------------------------------------------------------ */
12461 /*
12462 * <declarered begin> ::= <mp declarereduction>
12463 */
12464 case DECLARERED_BEGIN1:
12465 if (sem.which_pass == 0)
12466 error(155, 2, gbl.lineno, "Unimplemented feature - DECLARE REDUCTION",
12467 NULL);
12469 break;
12470
12471 /* ------------------------------------------------------------------ */
12472 /*
12473 * <declare reduction> ::= ( <reduc op> : <type list> : <red comb> ) <opt
12474 *red init>
12475 */
12476 case DECLARE_REDUCTION1:
12477 break;
12478
12479 /* ------------------------------------------------------------------ */
12480 /*
12481 * <type list> ::= <type list> , <red type> |
12482 */
12483 case TYPE_LIST1:
12484 break;
12485 /*
12486 * <type list> ::= <red type>
12487 */
12488 case TYPE_LIST2:
12489 break;
12490
12491 /* ------------------------------------------------------------------ */
12492 default:
12493 interr("semant1:bad rednum", rednum, 3);
12494 break;
12495 }
12496}
12497
12498/** Make a unique func ast with a unique sptr (and name) so we can
12499 set its associated pointer field. The unique sptr is a placeholder
12500 for the pointer target so it does not conflict with the
12501 original ST_PROC symbol. We hold the original pointer target
12502 in the PTR_TARGET field.
12503*/
12504static void
12506
12507{
12508 SPTR sym, orig_sym = sym_of_ast(ast);
12509
12510 sym = get_next_sym(SYMNAME(orig_sym), "tgt");
12511 STYPEP(sym, STYPEG(orig_sym));
12512 SCP(sym, SCG(orig_sym));
12513 SCOPEP(sym, SC_NONE);
12514 ASSOC_PTRP(sym, sptr);
12515 PTR_TARGETP(sym, orig_sym);
12516 PTR_TARGETP(sptr, orig_sym);
12517 DINITP(sym, 1);
12519 SST_ASTP(stkptr, ast);
12520 if (STYPEG(SCOPEG(orig_sym)) == ST_MODULE) {
12521 INMODULEP(orig_sym, 1);
12522 }
12523}
12524
12525static void
12526gen_dinit(int sptr, SST *stkptr)
12527{
12528 switch (STYPEG(sptr)) { /* change symbol type if necessary */
12529 case ST_UNKNOWN:
12530 case ST_IDENT:
12531 STYPEP(sptr, ST_VAR);
12533 case ST_VAR:
12534 case ST_ARRAY:
12535 if (SCG(sptr) == SC_NONE)
12536 SCP(sptr, SC_LOCAL);
12537 if (!dinit_ok(sptr))
12538 return;
12539 break;
12540 case ST_STAG:
12541 case ST_STRUCT:
12542 case ST_MEMBER:
12543 break;
12544 case ST_GENERIC:
12545 case ST_INTRIN:
12546 case ST_PD:
12547 if ((sptr = newsym(sptr)) == 0)
12548 /* Symbol frozen as an intrinsic, ignore data initialization */
12549 return;
12550 break;
12551 default:
12552 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
12553 return;
12554 }
12555
12556 if (flg.xref)
12557 xrefput(sptr, 'i');
12558
12559 if (SCG(sptr) == SC_DUMMY) {
12560 /* Dummy variables may not be initialized */
12561 error(41, 3, gbl.lineno, SYMNAME(sptr), CNULL);
12563 }
12564
12565 if (sem.dinit_count > 0) {
12566 errsev(66);
12568 }
12569
12570 /* Call dinit to generate dinit records */
12571 if (INSIDE_STRUCT) {
12572 /* In structure so accumulate Initializer Constant Tree
12573 * in the structure stack.
12574 */
12575 /* Set first constant to point to variable needing init'd */
12576 (SST_CLBEGG(stkptr))->sptr = sptr;
12577 stsk = &STSK_ENT(0);
12578 if (stsk->ict_beg) {
12579 (stsk->ict_end)->next = SST_CLBEGG(stkptr);
12580 stsk->ict_end = SST_CLENDG(stkptr);
12581 } else {
12582 stsk->ict_beg = SST_CLBEGG(stkptr);
12583 stsk->ict_end = SST_CLENDG(stkptr);
12584 }
12585 } else {
12586 /* Not in structure so generate dinit records */
12587 if (!sem.dinit_error) {
12588 SST tmpsst;
12589 VAR *ivl;
12590 mkident(&tmpsst);
12591 SST_SYMP(&tmpsst, sptr);
12592 SST_DTYPEP(&tmpsst, DTYPEG(sptr));
12593 SST_SHAPEP(&tmpsst, 0);
12594 SST_ASTP(&tmpsst, mk_id(sptr));
12595 SST_SHAPEP(&tmpsst, A_SHAPEG(SST_ASTG(&tmpsst)));
12596 ivl = dinit_varref(&tmpsst);
12597 dinit(ivl, SST_CLBEGG(stkptr));
12598 }
12600 }
12601}
12602
12603static void
12605{
12606 int scope;
12607 if (sem.none_implicit) {
12608 int i, arg;
12609 int *dscptr;
12610
12611 dscptr = aux.dpdsc_base + DPDSCG(gbl.currsub);
12612 for (i = PARAMCTG(gbl.currsub); i > 0; i--)
12613 if ((arg = *dscptr++)) {
12614 /* any implicit typing needs to be explicit */
12615 switch (STYPEG(arg)) {
12616 case ST_VAR:
12617 case ST_ARRAY:
12618 DCLCHK(arg);
12619 DCLDP(arg, TRUE);
12620 break;
12621 case ST_PROC:
12622 if (FUNCG(arg)) {
12623 DCLCHK(arg);
12624 DCLDP(arg, TRUE);
12625 }
12626 break;
12627 default:
12628 break;
12629 }
12630 }
12631 }
12632 if (gbl.rutype == RU_FUNC) {
12633 DCLCHK(gbl.currsub);
12634 DCLDP(gbl.currsub, TRUE); /* any implicit typing needs to be explicit */
12635 }
12636
12637 STYPEP(gbl.currsub, ST_PROC);
12638 if (sem.interface && SCG(gbl.currsub) == SC_DUMMY) {
12639 /* if this is a interface block definition of a subprogram
12640 * for a dummy argument, force it to appear in an external statement */
12641 TYPDP(gbl.currsub, 1);
12642 IS_PROC_DUMMYP(gbl.currsub, 1);
12643 }
12644 /* if this is an interface block for the program we are compiling,
12645 * ignore this symbol henceforth */
12646 scope = SCOPEG(gbl.currsub);
12647 if (scope && NMPTRG(gbl.currsub) == NMPTRG(scope)) {
12648 IGNOREP(gbl.currsub, TRUE);
12649 pop_sym(gbl.currsub);
12650 }
12651 gbl.currsub = 0;
12652 gbl.rutype = 0;
12658}
12659
12660static void
12661set_len_attributes(SST *stkptr, int lvl)
12662{
12663 /* lenspec[].kind */ /* 0 - length not present
12664 * 1 - constant length
12665 * 2 - length is '*'
12666 * 3 - length is zero
12667 * 4 - length is adjustable
12668 * 5 - length is ':'
12669 */
12670 /* lenspec[].len */ /* -1 if length not present;
12671 * -2 if zero length;
12672 * -3 if ':';
12673 * 0 if '*';
12674 * constant value if length is constant;
12675 * ast of adjustable length expression.
12676 */
12677 if (SST_IDG(stkptr) == 0) {
12678 lenspec[lvl].len = SST_SYMG(stkptr);
12679 switch (lenspec[lvl].len) {
12680 case -1:
12681 lenspec[lvl].kind = 0;
12682 break;
12683 case -2:
12684 lenspec[lvl].kind = _LEN_ZERO;
12685 break;
12686 default:
12687 lenspec[lvl].kind = _LEN_CONST;
12688 }
12689 } else {
12690 lenspec[lvl].len = SST_ASTG(stkptr);
12691 if (lenspec[lvl].len == 0 && SST_SYMG(stkptr) == -1) {
12692 lenspec[lvl].kind = _LEN_DEFER;
12693 } else if (lenspec[lvl].len == 0)
12694 lenspec[lvl].kind = _LEN_ASSUM;
12695 else
12696 lenspec[lvl].kind = _LEN_ADJ;
12697 }
12698 if (lvl == 0 || (lenspec[1].kind == 0 && lenspec[0].kind)) {
12699 /* propagate the global length attributes if:
12700 * 1. the global attributes are being set, or
12701 * 2. the augmented attributes were not present and the global
12702 * attributes were present.
12703 */
12704 lenspec[1] = lenspec[0];
12705 lenspec[1].propagated = 1;
12706 } else {
12707 lenspec[lvl].propagated = 0;
12708 }
12709}
12710
12711static void
12713{
12714 int dtype;
12715 dtype = *pdtype;
12716 if (DTY(dtype) != TY_CHAR && DTY(dtype) != TY_NCHAR)
12717 return;
12718 if (lenspec[1].kind == _LEN_ADJ) {
12719 ADJLENP(sptr, 1);
12720 }
12721 if (lenspec[1].kind == _LEN_ASSUM) {
12722 ASSUMLENP(sptr, 1);
12723 }
12724}
12725
12726static void
12727set_aclen(SST *stkptr, int ivl, int flag)
12728{
12729 static int kind0, kind1, propagate0, propagate1;
12730 static INT len0, len1;
12731
12732 if (flag) {
12733 len0 = lenspec[0].len;
12734 kind0 = lenspec[0].kind;
12735 propagate0 = lenspec[0].propagated;
12736 len1 = lenspec[1].len;
12737 kind1 = lenspec[1].kind;
12738 propagate1 = lenspec[1].propagated;
12739 lenspec[0].len = 0;
12740 lenspec[0].kind = 0;
12741 lenspec[0].propagated = 0;
12742 lenspec[1].len = 0;
12743 lenspec[1].kind = 0;
12744 lenspec[1].propagated = 0;
12745
12746 set_len_attributes(stkptr, ivl);
12747 } else {
12748 lenspec[0].len = len0;
12749 lenspec[0].kind = kind0;
12750 lenspec[0].propagated = propagate0;
12751 lenspec[1].len = len1;
12752 lenspec[1].kind = kind1;
12753 lenspec[1].propagated = propagate1;
12754 }
12755}
12756
12757#ifdef FLANG_SEMANT_UNUSED
12758static int
12759get_actype(SST *stkptr, int ivl)
12760{
12761 sem.gdtype = mod_type(sem.gdtype, sem.gty, lenspec[ivl].kind,
12762 lenspec[ivl].len, lenspec[ivl].propagated, 0);
12763 return sem.gdtype;
12764}
12765#endif
12766
12767static void
12768ctte(int entry, int sptr)
12769{
12770 int dtype;
12771 ADJARRP(entry, ADJARRG(sptr));
12772 ADJLENP(entry, ADJLENG(sptr));
12773 ALLOCP(entry, ALLOCG(sptr));
12774 ASSUMSHPP(entry, ASSUMSHPG(sptr));
12775 ASUMSZP(entry, ASUMSZG(sptr));
12776 DCLDP(entry, DCLDG(sptr));
12777 DTYPEP(entry, DTYPEG(sptr));
12778 POINTERP(entry, POINTERG(sptr));
12779 F90POINTERP(entry, F90POINTERG(sptr));
12780 SEQP(entry, SEQG(sptr));
12781 /* check that the datatype is a legal function datatype */
12782 dtype = DTYPEG(sptr);
12783 if (POINTERG(sptr)) {
12784 /* cannot be a character(len=*) */
12785 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
12786 error(155, 3, gbl.lineno,
12787 "Function result cannot be assumed-length character pointer -",
12788 SYMNAME(sptr));
12789 POINTERP(sptr, FALSE);
12790 POINTERP(entry, FALSE);
12791 }
12792 }
12793 if (DTY(dtype) == TY_ARRAY) {
12794 /* cannot be a character(len=*) */
12795 if (DTY(dtype + 1) == DT_ASSCHAR || DTY(dtype + 1) == DT_ASSNCHAR) {
12796 error(155, 3, gbl.lineno,
12797 "Function result cannot be assumed-length character array -",
12798 SYMNAME(sptr));
12799 DTYPEP(sptr, DTY(dtype + 1));
12800 DTYPEP(entry, DTY(dtype + 1));
12801 dtype = DTY(dtype + 1);
12802 }
12803 }
12804} /* ctte */
12805
12806static void
12808{
12809 if (RESULTG(sptr)) {
12810 if (sem.interface) {
12811 /* find the entry symbol in the interface block */
12812 int sl, e;
12813 for (sl = sem.scope_level; sl > 0; --sl) {
12814 e = sem.scope_stack[sl].sptr;
12815 if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) {
12816 if (FVALG(e) == sptr)
12817 ctte(e, sptr);
12818 }
12820 break;
12821 }
12822 for (e = sem.scope_stack[sl].symavl; e < stb.stg_avail; ++e) {
12823 if (STYPEG(e) == ST_ENTRY || STYPEG(e) == ST_PROC) {
12824 if (FVALG(e) == sptr)
12825 ctte(e, sptr);
12826 }
12827 }
12828 } else {
12829 int e;
12830 /* scan all entries. NOTE: gbl.entries not yet set */
12831 for (e = gbl.currsub; e > NOSYM; e = SYMLKG(e)) {
12832 if (FVALG(e) == sptr)
12833 ctte(e, sptr);
12834 }
12835 }
12836 }
12837} /* copy_type_to_entry */
12838
12839static void
12841{
12842 state->currsub = gbl.currsub;
12843 state->rutype = gbl.rutype;
12845 state->pgphase = sem.pgphase;
12849 state->gnr_rutype = 0;
12850 state->nml = sem.nml;
12851
12852 gbl.currsub = 0;
12853 gbl.rutype = 0;
12854 sem.module_procedure = false;
12859 save_implicit(FALSE); /* save host's implicit state */
12860}
12861
12862static void
12863restore_host(INTERF *state, LOGICAL keep_implicit)
12864{
12865 gbl.currsub = state->currsub;
12866 gbl.rutype = state->rutype;
12868 sem.pgphase = state->pgphase;
12872 sem.nml = state->nml;
12873 restore_implicit(); /* restore host's implicit state */
12874 if (keep_implicit) {
12876 /* in a contained subprogram, ignore host's implicit/parameter stmts */
12879 }
12880}
12881
12882/* return TRUE if the name on the end is different from the name
12883 * of the routine */
12884static LOGICAL
12886{
12887 if (endname == 0)
12888 return FALSE;
12889 if (UNAMEG(gbl.currsub)) {
12890 /* compare to the original name */
12891 char *uname = stb.n_base + UNAMEG(gbl.currsub);
12892 return strcmp(uname, SYMNAME(endname)) != 0;
12893 }
12894 return strcmp(SYMNAME(gbl.currsub), SYMNAME(endname)) != 0;
12895} /* wrong_name */
12896
12897/** Reset scopes and related set ups after processing and subroutine
12898 */
12899static void
12901{
12902 fix_iface(gbl.currsub);
12903 if (sem.interface && IN_MODULE) {
12905 }
12906 if (sem.which_pass && !sem.interface) {
12907 fix_class_args(gbl.currsub);
12908 }
12909 if (/*!IN_MODULE*/ !sem.mod_cnt && !sem.interface) {
12910 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_END);
12911 queue_tbp(0, 0, 0, 0, TBP_CLEAR);
12912 }
12913 defer_pt_decl(0, 0);
12914 dummy_program();
12915 check_end_subprogram(rutype, SST_SYMG(RHS(2)));
12916
12917 SST_IDP(LHS, 1); /* mark as end of subprogram unit */
12918 if (IN_MODULE && sem.interface == 0)
12922 if (!IN_MODULE && !sem.interface)
12926}
12927
12928static void
12930{
12931 if (gbl.currsub == 0) {
12932 if (sem.pgphase == PHASE_INIT && gbl.internal) {
12933 /* end of subprogram containing internal subprograms */
12935 gbl.internal = 0;
12936 check_end_subprogram(rutype, sym);
12937 end_of_host = gbl.currsub;
12938 gbl.currsub = 0;
12939 if (sem.which_pass)
12940 end_contained();
12941 if (scn.currlab && sem.which_pass == 0)
12942 /* The end statement of the host subprogram is labeled.
12943 * Save its number for when the host's CONTAINS statement is
12944 * processed during the second pass.
12945 */
12947 return;
12948 }
12949 if (gbl.internal && sem.pgphase == PHASE_END && sem.which_pass == 0) {
12950 /* end of module subprogram containing internal subprograms */
12952 gbl.internal = 0;
12954 return;
12955 }
12956 error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL);
12957 gbl.internal = 0;
12958 } else if (gbl.rutype != rutype) {
12959 error(302, 3, gbl.lineno, name_of_rutype(rutype), CNULL);
12960 } else if (sym && wrong_name(sym))
12961 error(309, 3, gbl.lineno, SYMNAME(sym), CNULL);
12962
12964}
12965
12966static const char *
12968{
12969 switch (rutype) {
12970 case RU_SUBR:
12971 return "SUBROUTINE";
12972 case RU_FUNC:
12973 return "FUNCTION";
12974 case RU_PROC:
12975 return "PROCEDURE";
12976 case RU_PROG:
12977 return "PROGRAM";
12978 case RU_BDATA:
12979 return "BLOCKDATA";
12980 }
12981 return "";
12982}
12983
12984/* If an intrinsic is declared in a host subprogram and not otherwise used,
12985 * convert it to an identifier for the internal subprograms to share.
12986 */
12987static void
12989{
12990 SPTR sptr;
12991 assert(gbl.currsub && gbl.internal == 0,
12992 "only applicable for non-internal subprogram", 0, ERR_Severe);
12993 for (sptr = NOSYM + 1; sptr < stb.firstusym; ++sptr) {
12994 if (DCLDG(sptr) && !EXPSTG(sptr) && IS_INTRINSIC(STYPEG(sptr))) {
12995 SPTR new_sptr = newsym(sptr);
12996 STYPEP(new_sptr, ST_IDENT);
12997 }
12998 }
12999}
13000
13001/*
13002 * In certain contexts, a new symbol must be created immediately
13003 * if the identifier is an intrinsic rather than relying on newsym().
13004 * For example, calling newsym() on a formal argument in an interface
13005 * block creates a new symbol as expected, but the effects of the
13006 * appearance of the intrinsic name in a type statement in an outer
13007 * scope are applied to the new symbol:
13008 * integer cos <- sets the DCLD flag of the generic
13009 * interface
13010 * subroutine sub(cos)
13011 * integer cos <- newsym, but generic's DCLD flag is applied
13012 * endsubroutine
13013 * endinterface
13014 * call sub(cos) <- the first type statement no longer applies
13015 */
13016static int
13018{
13019 int oldsptr;
13020 int sptr;
13021
13022 sptr = getocsym(first, OC_OTHER, FALSE);
13023 if (IS_INTRINSIC(STYPEG(sptr))) {
13024 if ((sem.interface && DCLDG(sptr)) || now) {
13025 error(35, 1, gbl.lineno, SYMNAME(sptr), CNULL);
13026 oldsptr = sptr;
13027 sptr = insert_sym(sptr);
13028 if (now && settype && DCLDG(oldsptr)) {
13029 DTYPEP(sptr, DTYPEG(oldsptr));
13030 DCLDP(sptr, TRUE);
13031 }
13032 }
13033 }
13034 return sptr;
13035}
13036
13037/*
13038 * Create a ST_ENTRY for a function ENTRY. Must be aware of the situation
13039 * where a variable named the same as the entry already exists.
13040 */
13041static int
13043{
13044 int func_result = chk_func_entry_result(sptr);
13045 if (func_result > NOSYM) {
13046 sptr = 0;
13047 if (sem.which_pass && IN_MODULE) {
13048 /* if in a module, we have already seen the ENTRY during
13049 * which_pass == 0; get THAT symbol */
13050 for (sptr = first_hash(func_result); sptr > NOSYM; sptr = HASHLKG(sptr)) {
13051 if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_PROC &&
13052 FVALG(sptr) == func_result) {
13053 break;
13054 }
13055 if (NMPTRG(sptr) == NMPTRG(func_result) && STYPEG(sptr) == ST_ALIAS &&
13056 STYPEG(SYMLKG(sptr)) == ST_PROC &&
13057 SCOPEG(SYMLKG(sptr)) == SCOPEG(func_result)) {
13058 break;
13059 }
13060 }
13061 }
13062 /* sptr is the old symbol for the entry point, now an ST_PROC */
13063 if (sptr) {
13064 int fval;
13065 if (STYPEG(sptr) == ST_ALIAS) {
13066 fval = FVALG(SYMLKG(sptr));
13067 } else {
13068 fval = FVALG(sptr);
13069 }
13070 if (fval) {
13071 STYPEP(fval, ST_UNKNOWN);
13072 IGNOREP(fval, TRUE);
13073 HIDDENP(fval, TRUE);
13074 FVALP(sptr, 0);
13075 }
13076 } else {
13077 /* A variable is already defined in the same scope of
13078 * the entry and assume that the variable's declaration
13079 * is for the entry. Create a new symbol as the
13080 * ST_ENTRY; make the variable found by chk_func_entry_result
13081 * the function result of the ST_ENTRY.
13082 */
13083 sptr = insert_sym(func_result);
13084 }
13085
13086 SCP(func_result, SC_DUMMY);
13087 RESULTP(func_result, TRUE);
13088 pop_sym(func_result);
13089 sptr = declsym(sptr, ST_ENTRY, TRUE);
13090 DTYPEP(sptr, DTYPEG(func_result));
13091 ADJLENP(sptr, ADJLENG(func_result));
13092 DCLDP(sptr, DCLDG(func_result));
13093 FVALP(sptr, func_result);
13094 return sptr;
13095 }
13096 sptr = declsym(sptr, ST_ENTRY, TRUE);
13097 if (SCG(sptr) != SC_NONE)
13098 error(43, 3, gbl.lineno, SYMNAME(sptr), CNULL);
13099 return sptr;
13100}
13101
13102/*
13103 * Create the result variable for a function ENTRY. Must be aware of the
13104 * situation where a variable named the same as the 'result' already exists.
13105 */
13106static int
13108{
13109 int func_result = chk_func_entry_result(sptr);
13110 if (func_result > NOSYM) {
13111 /* A variable is already defined in the same scope of
13112 * the entry and assume that the variable's declaration
13113 * is for the entry. Just use the variable as the
13114 * result of the entry.
13115 */
13116 SCP(func_result, SC_DUMMY);
13117 RESULTP(func_result, TRUE);
13118 return func_result;
13119 }
13120 sptr = declsym(sptr, ST_IDENT, TRUE);
13121 SCP(sptr, SC_DUMMY);
13122 return sptr;
13123}
13124
13125/*
13126 * Retrieve/create a variable in the current scope. Must be aware of
13127 * the situation where a variable is a function in which case, its
13128 * result variable must be used.
13129 */
13130static int
13132{
13133 int sptr;
13134 sptr = refsym_inscope(sym, OC_OTHER);
13135 switch (STYPEG(sptr)) {
13136 case ST_ENTRY:
13137 if (gbl.rutype != RU_FUNC) {
13138 error(43, 3, gbl.lineno, "subprogram or entry name", SYMNAME(sptr));
13139 sptr = insert_sym(sptr);
13140 } else {
13141 /* should we specify the RESULT name? */
13142 if (RESULTG(sptr)) {
13143 error(43, 3, gbl.lineno, SYMNAME(sptr),
13144 "- you must specify the RESULT name");
13145 }
13146 sptr = FVALG(sptr);
13147 }
13148 break;
13149 case ST_MODULE:
13150 if (!DCLDG(sptr)) {
13151 /*
13152 * if the module is indirectly USEd (DCLD is not set)
13153 * it's ok to create a new symbol when used.
13154 * Otherwise, the module name is stll visible.
13155 */
13156 sptr = insert_sym(sptr);
13157 }
13158 break;
13159 default:;
13160 }
13161 return sptr;
13162}
13163
13164/*
13165 * For entries, the variable specified in the result clause or
13166 * the variable implied by the entry name may have already been
13167 * declared in the same scope; also, the variable may have already
13168 * been referenced. Determine if a variable has already been declared
13169 * whose name is the same as the entry or the result variable.
13170 */
13171static int
13173{
13174 int sptr2;
13175
13176 sptr = refsym(sptr, OC_OTHER);
13177 switch (STYPEG(sptr)) {
13178 case ST_IDENT:
13179 case ST_VAR:
13180 case ST_ARRAY:
13181 switch (SCG(sptr)) {
13182 case SC_NONE:
13183 case SC_LOCAL:
13184 sptr2 = SCOPEG(sptr);
13185 if (sptr2 == 0)
13186 break;
13187 if (STYPEG(sptr2) == ST_ALIAS)
13188 sptr2 = SYMLKG(sptr2);
13189 if (sptr2 == gbl.currsub) {
13190 /* A variable is already defined in the same scope of
13191 * the entry and assume that the variable's declaration
13192 * is for the entry or the result.
13193 */
13194 return sptr;
13195 }
13196 break;
13197 default:;
13198 }
13199 break;
13200 default:;
13201 }
13202 /* a variable with the same name doesn't exist in the same scope: */
13203 return 0;
13204}
13205
13206static void
13207get_param_alias_const(SST *stkp, int param_sptr, int dtype)
13208{
13209 int ast;
13210 int alias;
13211 INT conval;
13212 ACL *aclp;
13213
13214 if (SST_IDG(stkp) == S_EXPR) {
13215 aclp = construct_acl_from_ast(SST_ASTG(stkp), dtype, 0);
13216 if (sem.dinit_error || !aclp) {
13217 return;
13218 }
13219 aclp = eval_init_expr(aclp);
13220 conval = cngcon(aclp->conval, aclp->dtype, dtype);
13221 } else if (SST_IDG(stkp) == S_LVALUE && stkp->value.cnval.acl) {
13223 aclp = SST_ACLG(stkp);
13224 if (sem.dinit_error || !aclp) {
13225 return;
13226 }
13227 aclp = eval_init_expr(aclp);
13228 conval = cngcon(aclp->conval, aclp->dtype, dtype);
13229 } else {
13230 conval = chkcon(stkp, dtype, FALSE);
13231 }
13232 CONVAL1P(param_sptr, conval);
13233 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR ||
13234 dtype == DT_DEFERNCHAR)
13235 DTYPEP(param_sptr, DTYPEG(CONVAL1G(param_sptr)));
13236 alias = mk_cval1(conval, (int)DTYPEG(param_sptr));
13237 CONVAL2P(param_sptr, alias); /* ast of <expression> */
13238 if (sem.interface == 0)
13239 add_param(param_sptr);
13240 /* create an ast for the parameter; set the alias field of the ast
13241 * so that we don't have to set the alias field whenever the
13242 */
13243 ast = mk_id(param_sptr);
13244 A_ALIASP(ast, alias);
13245}
13246
13247/* get the char length from the initialization expression */
13248static void
13250{
13251 int sdtype = DTYPEG(sptr);
13252 int ndtype = init_acl->dtype;
13253
13254 if (DTY(ndtype) == TY_ARRAY)
13255 ndtype = DTY(ndtype + 1);
13256 /* get the new char length */
13257 if (DTY(sdtype) == TY_ARRAY) {
13258 /* make array type with new char subtype, same bounds */
13259 ndtype = get_type(3, TY_ARRAY, ndtype);
13260 DTY(ndtype + 2) = DTY(sdtype + 2);
13261 }
13262 DTYPEP(sptr, ndtype);
13263}
13264
13265static void
13267{
13268 int sptr;
13269 int sptr1;
13270 int dtype;
13271 ADSC *ad;
13272 int sdtype;
13273 ACL *aclp;
13274
13275 sptr = SST_SYMG(var);
13276 PARAMP(sptr, 1);
13277
13278 if (SST_IDG(init) == S_EXPR && A_TYPEG(SST_ASTG(init)) == A_INTR &&
13279 DTY(SST_DTYPEG(init)) == TY_ARRAY) {
13282
13283 sdtype = DTYPEG(sptr);
13284 if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
13285 DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
13287 }
13288 } else if (SST_IDG(init) == S_SCONST) {
13291
13292 sdtype = DTYPEG(sptr);
13293 if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
13294 DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
13296 }
13297 } else if (SST_IDG(init) == S_ACONST ||
13298 (SST_IDG(init) == S_IDENT &&
13299 (STYPEG(SST_SYMG(init)) == ST_PARAM || PARAMG(SST_SYMG(init))))) {
13300 sdtype = DTYPEG(sptr);
13301 if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
13302 DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERCHAR) {
13304 }
13305
13307 } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST &&
13308 (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
13309 DDTG(DTYPEG(sptr)) == DT_ASSNCHAR)) {
13312 } else if (DTY(DTYPEG(sptr)) == TY_ARRAY && SST_IDG(init) == S_CONST) {
13315 }
13316
13317 if ((STYPEG(sptr) == ST_ARRAY) && SCG(sptr) == SC_NONE &&
13318 SCOPEG(sptr) == stb.curr_scope) {
13319 STYPEP(sptr, ST_PARAM);
13320 if (flg.xref)
13321 xrefput(sptr, 'd');
13322 } else if (STYPEG(sptr) == ST_VAR && DTY(DTYPEG(sptr)) == TY_ARRAY &&
13323 SCOPEG(sptr) == stb.curr_scope) {
13324/* HACK: if the named constant being defined has an initializer
13325 * that contains an intrinsic call that uses the named constant
13326 * as an argument, then the argument handling may have
13327 * changed the item's STYPE to ST_VAR when array. Change it back to
13328 * an ST_PARAM.
13329 */
13330 STYPEP(sptr, ST_PARAM);
13331 if (flg.xref)
13332 xrefput(sptr, 'd');
13333
13334 } else if (STYPEG(sptr) == ST_VAR && SCOPEG(sptr) == stb.curr_scope &&
13335 KINDG(sptr)) {
13336 /* Overloaded type parameter */
13337 STYPEP(sptr, ST_PARAM);
13338 if (flg.xref)
13339 xrefput(sptr, 'd');
13340
13341 } else if (STYPEG(sptr) == ST_IDENT && SCOPEG(sptr) == stb.curr_scope) {
13342 STYPEP(sptr, ST_PARAM);
13343 if (flg.xref)
13344 xrefput(sptr, 'd');
13345
13346 } else {
13347 sptr = declsym(sptr, ST_PARAM, TRUE);
13348 if (SCG(sptr) != SC_NONE) {
13349 error(43, 3, gbl.lineno, "symbol", SYMNAME(sptr));
13350 return;
13351 }
13352 }
13353
13354 dtype = DTYPEG(sptr);
13355 if (DTY(dtype) == TY_DERIVED) {
13356 sptr1 = get_param_alias_var(sptr, dtype);
13357 } else if (DTY(dtype) == TY_ARRAY) {
13358 ad = AD_DPTR(dtype);
13359 if (AD_ADJARR(ad) || AD_DEFER(ad)) {
13360 error(84, 3, gbl.lineno, SYMNAME(sptr),
13361 "- a named constant array must have constant extents");
13362 /* recover as zero sized array */
13363 int i;
13364 int ndim = AD_NUMDIM(ad);
13365 for (i = 0; i < ndim; i++) {
13366 AD_LWBD(ad, i) = AD_LWAST(ad, i) = astb.bnd.one;
13367 AD_UPBD(ad, i) = AD_UPAST(ad, i) = astb.bnd.zero;
13368 AD_EXTNTAST(ad, i) = astb.bnd.zero;
13369 AD_MLPYR(ad, i) = astb.bnd.zero;
13370 }
13371 AD_ZBASE(ad) = astb.bnd.one;
13372 AD_ADJARR(ad) = AD_DEFER(ad) = AD_NOBOUNDS(ad) = 0;
13373 goto param_alias;
13374 }
13375 if (AD_ASSUMSZ(ad)) {
13376 int i, dtype2;
13377 dtype2 = SST_DTYPEG(init);
13378 ADSC *ad2 = AD_DPTR(dtype2);
13379 int ndim1 = AD_NUMDIM(ad);
13380 int ndim2 = AD_NUMDIM(ad2);
13381 int lb1, ub1, lb2, ub2, zbase;
13382
13383 if (ndim1 != ndim2) {
13384 error(155, 3, gbl.lineno, "Implied-shape array must be initialized "
13385 "with an array of the same rank -", SYMNAME(sptr));
13386 DTY(dtype + 1) = DT_NONE;
13387 return ;
13388 }
13389 zbase = 0;
13390 for (i = 0; i < ndim1; i++) {
13391 lb2 = ad_val_of(sym_of_ast(AD_LWAST(ad2, i)));
13392 ub2 = ad_val_of(sym_of_ast(AD_UPAST(ad2, i)));
13393 lb1 = ad_val_of(sym_of_ast(AD_LWAST(ad, i)));
13394 if (ADD_LWAST(dtype2, i) == ADD_LWAST(dtype, i)) {
13395 AD_UPBD(ad, i) = AD_UPAST(ad, i) = AD_UPAST(ad2, i);
13396 AD_EXTNTAST(ad, i) = AD_EXTNTAST(ad2, i);
13397 } else {
13398 ub1 = ub2 - lb2 + lb1;
13399 AD_UPBD(ad, i) = AD_UPAST(ad, i) =
13401 AD_EXTNTAST(ad, i) =
13402 mk_shared_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
13403 }
13404 if (i == 0)
13405 zbase = zbase + lb1;
13406 else
13407 zbase = zbase + lb1 * (ub2 - lb2 + 1);
13408 AD_MLPYR(ad, i) = AD_MLPYR(ad2, i);
13409 }
13411 if (i == ndim1)
13412 AD_MLPYR(ad, i) = AD_MLPYR(ad2, i);
13413 AD_ASSUMSZ(ad) = 0;
13414 }
13415 param_alias:
13416 sptr1 = get_param_alias_var(sptr, dtype);
13417 STYPEP(sptr1, ST_ARRAY);
13418 if (sem.interface == 0) {
13420 }
13421 } else {
13423
13424 sdtype = DTYPEG(sptr);
13425 if (DDTG(sdtype) == DT_ASSCHAR || DDTG(sdtype) == DT_ASSNCHAR ||
13426 DDTG(sdtype) == DT_DEFERCHAR || DDTG(sdtype) == DT_DEFERNCHAR) {
13428 }
13429 }
13430}
13431
13432static void
13434{
13435 ACL *ict = NULL;
13436
13437 if (!stsk->ict_beg) {
13438 DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
13439 /* Pop out to parent structure (if any) */
13440 sem.stsk_depth--;
13441 stsk = &STSK_ENT(0);
13442 return;
13443 }
13444
13445 if (sem.stsk_depth == 1 && stsk->ict_beg != NULL) {
13446 /* This is the outer most structure, fix up top subc ict entry */
13447 ict = GET_ACL(15);
13448 ict->id = AC_TYPEINIT;
13449 ict->next = NULL;
13450 ict->subc = stsk->ict_beg;
13451 ict->repeatc = astb.i1;
13452 ict->sptr = sptr;
13453 ict->dtype = dtype;
13454 stsk->ict_beg = ict;
13455 }
13456 df_dinit(NULL, ict);
13458
13459 DCLDP(DTY(dtype + 3), TRUE); /* "complete" tag declaration */
13460
13461 /* Pop out to parent structure (if any) */
13462 sem.stsk_depth--;
13463 stsk = &STSK_ENT(0);
13464
13465}
13466
13467void
13469{
13470 ACL *ict;
13471 ACL *ict1;
13472 int td_dtype;
13473
13474 td_dtype = DDTG(dtype);
13475
13476 ict1 = (ACL *)get_getitem_p(DTY(td_dtype + 5));
13477 if (ict1) {
13478 /* Need to build an initializer constant tree */
13479 ict = GET_ACL(15);
13480 *ict = *ict1;
13481 ict->sptr = sptr;
13482 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
13483 ict->repeatc = AD_NUMELM(AD_PTR(sptr));
13484 else
13485 ict->repeatc = astb.i1;
13486 if (ict->sptr)
13487 save_struct_init(ict);
13488 if (INSIDE_STRUCT) {
13489 if (stsk->ict_end)
13490 stsk->ict_end->next = ict;
13491 else
13492 stsk->ict_beg = ict;
13493 stsk->ict_end = ict;
13494 } else {
13495 /* For initialized sptr, don't create init list */
13496 if (DINITG(sptr) && DTY(td_dtype) == TY_DERIVED && !SAVEG(sptr))
13497 return;
13498
13499 dinit_no_dinitp((VAR *)NULL, ict);
13500 }
13501 }
13502}
13503
13504static void
13506{
13507 DTYPE td_dtype = DTYPEG(td_sptr);
13508 SPTR sptr = 0;
13509 SPTR fld_sptr;
13510 ACL *td_aclp;
13511 ACL **aclpp;
13512 int init_ict = get_struct_initialization_tree(td_dtype);
13513
13514 if (init_ict) {
13515 td_aclp = get_getitem_p(init_ict);
13516 } else {
13517 td_aclp = GET_ACL(15);
13518 td_aclp->id = AC_TYPEINIT;
13519 td_aclp->sptr = td_sptr;
13520 td_aclp->dtype = td_dtype;
13521 }
13522 aclpp = &td_aclp->subc;
13523
13524 for (fld_sptr = DTY(td_dtype + 1); fld_sptr > NOSYM;
13525 fld_sptr = SYMLKG(fld_sptr)) {
13526 ACL *aclp = NULL;
13527 DTYPE fld_dtype = DTYPEG(fld_sptr);
13528 if (is_array_dtype(fld_dtype))
13529 fld_dtype = array_element_dtype(fld_dtype);
13530
13531 /* position the init list ptr */
13532 if (*aclpp) {
13533 for (sptr = td_sptr;
13534 sptr > NOSYM && sptr != fld_sptr && sptr != (*aclpp)->sptr;
13535 sptr = SYMLKG(sptr))
13536 continue;
13537 if (sptr == (*aclpp)->sptr) {
13538 /* this field already has an initializer */
13539 aclpp = &(*aclpp)->next;
13540 continue;
13541 }
13542 }
13543
13544 if (DTY(fld_dtype) == TY_DERIVED && ALLOCFLDG(sptr)) {
13547 } else if (ALLOCATTRG(fld_sptr)) {
13549 }
13550 if (aclp) {
13551 aclp->sptr = MIDNUMG(fld_sptr);
13552 aclp->next = *aclpp;
13553 *aclpp = aclp;
13554 aclpp = &aclp->next;
13555 }
13556 }
13557
13558 df_dinit(NULL, td_aclp);
13559 if (!init_ict) { /* this is the "initialization tree" field */
13560 DTY(td_dtype + 5) = put_getitem_p(td_aclp);
13561 }
13562}
13563
13564static void
13565symatterr(int sev, int sptr, const char *att)
13566{
13567 char buf[100];
13568 snprintf(buf, sizeof buf, "Attribute '%s' cannot be applied to symbol", att);
13569 buf[sizeof buf - 1] = '\0'; /* Windows snprintf bug workaround */
13570 error(155, sev, gbl.lineno, buf, SYMNAME(sptr));
13571}
13572
13573static void
13574fixup_function_return_type(int retdtype, int dtsptr)
13575{
13576 dtsptr = lookupsymbol(SYMNAME(dtsptr));
13577 if (dtsptr && dtsptr != DTY(retdtype + 3)) {
13578 DTYPEP(gbl.currsub, DTYPEG(dtsptr));
13579 DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr));
13580 } else if (sem.pgphase > PHASE_SPEC) {
13581 error(4, 3, FUNCLINEG(gbl.currsub),
13582 "Function return type has not been declared", CNULL);
13583 DTYPEP(gbl.currsub, DTYPEG(dtsptr));
13584 DTYPEP(FVALG(gbl.currsub), DTYPEG(dtsptr));
13585 }
13586}
13587
13588static int
13590{
13591 int newast = ast;
13592 int tmp_ast1 = 0;
13593 int tmp_ast2 = 0;
13594 int sptr;
13595 int newsptr;
13596 int ndim;
13597 int subs[MAXRANK];
13598 int argt;
13599 int i;
13600 int changed;
13601
13602 switch (A_TYPEG(ast)) {
13603 case A_CNST:
13604 if (DT_ISREAL(A_DTYPEG(ast))) {
13605 newast = mk_convert(ast, DT_INT);
13606 }
13607 break;
13608 case A_SUBSCR: /* NECESSARY? */
13609 sptr = A_SPTRG(A_LOPG(ast));
13610 ndim = ADD_NUMDIM(DTYPEG(sptr));
13611 argt = A_ARGSG(ast);
13612 changed = tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13613 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13614 for (i = 0; i < ndim; i++) {
13615 changed |= tmp_ast2 = fixup_KIND_expr(ARGT_ARG(argt, i));
13616 subs[i] = tmp_ast2 ? tmp_ast2 : ARGT_ARG(argt, i);
13617 }
13618 if (changed) {
13619 newast = mk_subscr(tmp_ast1, subs, ndim, A_DTYPEG(ast));
13620 }
13621 break;
13622 case A_MEM: /* NECESSARY? */
13623 tmp_ast1 = fixup_KIND_expr(A_PARENTG(ast));
13624 tmp_ast2 = fixup_KIND_expr(A_MEMG(ast));
13625 if (tmp_ast1 || tmp_ast2) {
13626 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13627 tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast);
13628 newast = mk_member(tmp_ast1, tmp_ast2, A_DTYPEG(ast));
13629 }
13630 break;
13631 case A_UNOP:
13632 tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13633 if (tmp_ast1) {
13634 newast = mk_unop(A_OPTYPEG(ast), tmp_ast1, A_DTYPEG(ast));
13635 }
13636 break;
13637 case A_BINOP:
13638 tmp_ast1 = fixup_KIND_expr(A_LOPG(ast));
13639 tmp_ast2 = fixup_KIND_expr(A_ROPG(ast));
13640 if (tmp_ast1 || tmp_ast2) {
13641 tmp_ast1 = tmp_ast1 ? tmp_ast1 : A_LOPG(ast);
13642 tmp_ast2 = tmp_ast2 ? tmp_ast2 : A_ROPG(ast);
13643 newast = mk_binop(A_OPTYPEG(ast), tmp_ast1, tmp_ast2, DT_INT);
13644 }
13645 break;
13646 case A_FUNC:
13647 /* could be an subscripted array expr */
13648 sptr = findByNameStypeScope(SYMNAME(A_SPTRG(A_LOPG(ast))), ST_PARAM, 0);
13649 if (sptr && DTY(DTYPEG(sptr)) == TY_ARRAY) {
13650 tmp_ast1 = mk_id(CONVAL1G(sptr));
13651 ndim = ADD_NUMDIM(DTYPEG(sptr));
13652 if (ndim != A_ARGCNTG(ast))
13653 break;
13654 argt = A_ARGSG(ast);
13655 for (i = 0; i < ndim; i++) {
13656 subs[i] = ARGT_ARG(argt, i);
13657 }
13658 newast = mk_subscr(tmp_ast1, subs, ndim, DTYPEG(sptr));
13659 }
13660 break;
13661 case A_ID:
13662 sptr = A_SPTRG(ast);
13663 if (!SCOPEG(sptr) || sem.pgphase == PHASE_USE) {
13664 newsptr = findByNameStypeScope(SYMNAME(A_SPTRG(ast)), ST_PARAM, 0);
13665 if (newsptr != sptr) {
13666 if (STYPEG(newsptr) == ST_CONST) {
13667 /* MORE can this happen, A_ID&ST_CONST */
13668 newast = mk_cnst(newsptr);
13669 } else if (STYPEG(newsptr) == ST_PARAM) {
13670 newast = CONVAL2G(newsptr);
13671 } else {
13672 newast = 0;
13673 }
13674 }
13675 }
13676 break;
13677 }
13678 return newast;
13679}
13680
13681static int
13682eval_KIND_expr(int ast, int *val, int *dtyp)
13683{
13684 int val1;
13685 int val2;
13686 int tmp_ast1;
13687 int success = 0;
13688
13689 if (!ast)
13690 return 0;
13691
13692 if (A_ALIASG(ast)) {
13693 *dtyp = A_DTYPEG(ast);
13694 ast = A_ALIASG(ast);
13695 }
13696
13697 switch (A_TYPEG(ast)) {
13698 case A_CNST:
13699 *dtyp = A_DTYPEG(ast);
13700 *val = CONVAL2G(A_SPTRG(ast));
13701 success = 1;
13702 break;
13703 case A_UNOP:
13704 if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp)) {
13705 if (A_OPTYPEG(ast) == OP_SUB)
13706 *val = negate_const(val1, A_DTYPEG(ast));
13707 if (A_OPTYPEG(ast) == OP_LNOT)
13708 *val = ~(val1);
13709 *dtyp = A_DTYPEG(ast);
13710 success = 1;
13711 }
13712 break;
13713 case A_BINOP:
13714 if (eval_KIND_expr(A_LOPG(ast), &val1, dtyp) &&
13715 eval_KIND_expr(A_ROPG(ast), &val2, dtyp)) {
13716 *val = const_fold(A_OPTYPEG(ast), val1, val2, A_DTYPEG(ast));
13717 *dtyp = A_DTYPEG(ast);
13718 success = 1;
13719 }
13720 break;
13721 case A_SUBSCR:
13722 case A_MEM:
13723 tmp_ast1 = complex_alias(ast);
13724 if (eval_KIND_expr(tmp_ast1, &val1, dtyp)) {
13725 *val = val1;
13726 success = 1;
13727 }
13728 break;
13729 }
13730
13731 return success;
13732}
13733
13734static void
13736{
13737 int sptr;
13738 int sav_gbl_lineno = gbl.lineno;
13739 int val = -1;
13740 int dtyp;
13741 int l_ast1;
13742
13744
13745 /* Handle deferred KIND spec */
13746 if (A_TYPEG(sem.deferred_func_kind) == A_ID) {
13748 ST_PARAM, 0);
13749 if (sptr) {
13750 dtyp = DTYPEG(sptr);
13751 val = CONVAL1G(sptr);
13752 if (STYPEG(A_SPTRG(sem.deferred_func_kind)) == ST_UNKNOWN) {
13753 IGNOREP(A_SPTRG(sem.deferred_func_kind), TRUE);
13754 HIDDENP(A_SPTRG(sem.deferred_func_kind), TRUE);
13755 }
13756 }
13757 } else if (A_ISEXPR(A_TYPEG(sem.deferred_func_kind))) {
13759 if (!eval_KIND_expr(l_ast1, &val, &dtyp)) {
13760 val = -1;
13761 }
13762 }
13763
13764 if (val < 0) {
13765 errsev(87);
13766 goto exit;
13767 }
13768
13769 if (dtyp != DT_INT4) {
13770 errwarn(91);
13771 goto exit;
13772 }
13773
13774 if ((dtyp =
13775 select_kind(DTYPEG(gbl.currsub), DTY(DTYPEG(gbl.currsub)), val))) {
13776 DTYPEP(gbl.currsub, dtyp);
13777 DTYPEP(FVALG(gbl.currsub), dtyp);
13778 if ((sptr = findByNameStypeScope(SYMNAME(gbl.currsub), ST_ALIAS, 0))) {
13779 DTYPEP(sptr, dtyp);
13780 }
13781 }
13782
13783exit:
13784 gbl.lineno = sav_gbl_lineno;
13788}
13789
13790static void
13792{
13793 int sav_gbl_lineno = gbl.lineno;
13794 int dtyp = 0;
13795 int l_ast1;
13796
13798
13799 /* Handle deferred LEN spec */
13801 if (A_TYPEG(l_ast1) == A_CNST) {
13802 dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 1, CONVAL2G(A_SPTRG(l_ast1)),
13803 0, gbl.currsub);
13804 if (dtyp) {
13805 DTYPEP(gbl.currsub, dtyp);
13806 DTYPEP(FVALG(gbl.currsub), dtyp);
13807 }
13808 } else {
13809 dtyp = mod_type(sem.ogdtype, DTY(sem.ogdtype), 4, l_ast1, 0, gbl.currsub);
13810 if (dtyp) {
13811 DTYPEP(gbl.currsub, dtyp);
13812 ADJLENP(gbl.currsub, 1);
13813 DTYPEP(FVALG(gbl.currsub), dtyp);
13814 ADJLENP(FVALG(gbl.currsub), 1);
13815 }
13816 }
13817
13818 gbl.lineno = sav_gbl_lineno;
13821}
13822
13823static void
13825{
13826 int sptr;
13827 LOGICAL found = FALSE;
13828
13829 if (gbl.rutype == RU_FUNC) {
13831 sptr = HASHLKG(sptr)) {
13832 if (sptr == sem.deferred_dertype)
13833 continue;
13834 if (STYPEG(sptr) == ST_TYPEDEF && STYPEG(SCOPEG(sptr)) == ST_MODULE) {
13836 found = TRUE;
13837 break;
13838 }
13839 }
13840 }
13841
13842 if (found) {
13843 DTYPEP(gbl.currsub, DTYPEG(sptr));
13844 DTYPEP(FVALG(gbl.currsub), DTYPEG(sptr));
13845 } else {
13847 "Derived type has not been declared -",
13849 }
13850
13853}
13854
13855static void
13857{
13858 int b_type;
13859 int b_bitv;
13860 int need_altname = 0;
13861 char *np;
13862
13863 /* A module routine without an explicit C name uses the routine name. */
13864 if (!XBIT(58,0x200000)) {
13865 if ((bind_attr.exist & DA_B(DA_C)) &&
13866 !bind_attr.altname && INMODULEG(sptr) &&
13867 (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY)) {
13868 char *np = SYMNAME(sptr);
13870 bind_attr.altname = getstring(np, strlen(np));
13871 }
13872 }
13873
13874 b_type = 0;
13875 for (b_bitv = bind_attr.exist; b_bitv; b_bitv >>= 1, b_type++) {
13876
13877 if ((b_bitv & 1) == 0)
13878 continue;
13879
13880 switch (b_type) {
13881 case DA_ALIAS:
13882 /* An altname can't be empty. Exit early to use a "normal" mangled
13883 * variant of the primary symbol name. */
13884 np = stb.n_base + CONVAL1G(bind_attr.altname);
13885 if (!*np)
13886 return;
13887 ALTNAMEP(sptr, bind_attr.altname);
13888 break;
13889 case DA_C:
13890
13891#if defined(TARGET_OSX)
13892 /* add underscore to OSX common block names */
13893 if (STYPEG(sptr) == ST_CMBLK)
13894 need_altname = 1;
13895#endif
13896 /* NEW CFUNCP and REFERENCEP */
13897 CFUNCP(sptr, 1);
13898 if ((STYPEG(sptr) == ST_PROC) || (STYPEG(sptr) == ST_ENTRY)) {
13899 PASSBYREFP(sptr, 1);
13900 MSCALLP(sptr, 0);
13901 }
13902
13903 break;
13904 } /* end switch */
13905
13906 } /* end for */
13907
13908 if ((need_altname) && ALTNAMEG(sptr) == 0) {
13909 /* set default altname, so that no underbar gets added */
13910 ALTNAMEP(sptr, getstring(SYMNAME(sptr), strlen(SYMNAME(sptr))));
13911 }
13912} /* process_bind */
13913
13914static void
13916{
13917 IDENT_LIST *curr, *curr_next;
13918 IDENT_PROC_LIST *curr_proc, *curr_proc_next;
13919 long hashval;
13920
13921 if (!sem.which_pass || !dirty_ident_base || gbl.internal > 1) {
13922 return;
13923 }
13924
13925 for (hashval = 0; hashval < HASHSIZE; ++hashval) {
13926 for (curr = ident_base[hashval]; curr;) {
13927 for (curr_proc = curr->proc_list; curr_proc;) {
13928 curr_proc_next = curr_proc->next;
13929 FREE(curr_proc);
13930 curr_proc = curr_proc_next;
13931 }
13932 curr->proc_list = 0;
13933 curr_next = curr->next;
13934 FREE(curr);
13935 curr = curr_next;
13936 }
13937 ident_base[hashval] = 0;
13938 }
13939
13941}
13942
13943/** \brief Emit a warning if a duplicate subproblem prefix is used.
13944 */
13945static void
13946check_duplicate(bool checker, const char *op)
13947{
13948 if (checker)
13949 error(1054, ERR_Warning, gbl.lineno, op, NULL);
13950}
13951
13952/** \brief Reset subprogram prefixes to zeroes
13953 */
13954static void
13956{
13957 BZERO(subp, struct subp_prefix_t, 1);
13958}
13959
13960/** \brief MODULE prefix checking for subprograms
13961 C1547: cannot be inside a an abstract interface
13962 */
13963static void
13965{
13966 if (sem.interface && subp_prefix.module &&
13968 error(1055, ERR_Severe, gbl.lineno, NULL, NULL);
13969}
13970
13971static void
13972decr_ident_use(int ident, int proc)
13973{
13974 long hashval;
13975 IDENT_LIST *curr;
13976 IDENT_PROC_LIST *curr_proc;
13977
13978 if (sem.which_pass || !dirty_ident_base || gbl.internal <= 1) {
13979 return;
13980 }
13981 HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)))
13982 for (curr = ident_base[hashval]; curr; curr = curr->next) {
13983 if (strcmp(curr->ident, SYMNAME(ident)) == 0) {
13984 for (curr_proc = curr->proc_list; curr_proc;
13985 curr_proc = curr_proc->next) {
13986 if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) {
13987 curr_proc->usecnt -= 1;
13988 }
13989 }
13990 }
13991 }
13992}
13993
13994static void
13995defer_ident_list(int ident, int proc)
13996{
13997
13998 long hashval;
13999 IDENT_LIST *curr;
14000 IDENT_PROC_LIST *curr_proc;
14001
14002 if (STYPEG(ident) && SCOPEG(ident) == gbl.currsub && SCOPEG(ident) != proc) {
14003 /* Note: if STYPEG(ident) == 0, then this is an implicitly defined symbol */
14004 proc = SCOPEG(ident);
14005 }
14006 HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)));
14007 for (curr = ident_base[hashval]; curr; curr = curr->next) {
14008 if (strcmp(curr->ident, SYMNAME(ident)) != 0)
14009 continue;
14010 for (curr_proc = curr->proc_list; curr_proc; curr_proc = curr_proc->next) {
14011 if (strcmp(SYMNAME(proc), curr_proc->proc_name) == 0) {
14012 curr_proc->usecnt += 1;
14013 return; /* identifier and procedure already added */
14014 }
14015 }
14016 /* add procedure name */
14018 NEW(curr_proc, IDENT_PROC_LIST, 1);
14019 NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1);
14020 strcpy(curr_proc->proc_name, SYMNAME(proc));
14021 curr_proc->next = curr->proc_list;
14022 curr->proc_list = curr_proc;
14023 curr_proc->usecnt = 1;
14024 return;
14025 }
14026 /* add identifier and create new procedure list */
14027 NEW(curr, IDENT_LIST, 1);
14028 NEW(curr->ident, char, strlen(SYMNAME(ident)) + 1);
14029 strcpy(curr->ident, SYMNAME(ident));
14030 NEW(curr_proc, IDENT_PROC_LIST, 1);
14031 NEW(curr_proc->proc_name, char, strlen(SYMNAME(proc)) + 1);
14032 strcpy(curr_proc->proc_name, SYMNAME(proc));
14033 curr->proc_list = curr_proc;
14034 curr_proc->next = 0;
14035 curr_proc->usecnt = 1;
14036 curr->next = ident_base[hashval];
14037 ident_base[hashval] = curr;
14039}
14040
14041int
14043{
14044 long hashval;
14045 IDENT_LIST *curr;
14046 IDENT_PROC_LIST *curr_proc;
14047
14048 if (!dirty_ident_base)
14049 return 0;
14050
14051 HASH_STR(hashval, SYMNAME(ident), strlen(SYMNAME(ident)));
14052 for (curr = ident_base[hashval]; curr; curr = curr->next) {
14053 if (strcmp(curr->ident, SYMNAME(ident)) == 0) {
14054 for (curr_proc = curr->proc_list; curr_proc;
14055 curr_proc = curr_proc->next) {
14056 if (strcmp(curr_proc->proc_name, SYMNAME(proc)) == 0 &&
14057 curr_proc->usecnt > 0) {
14058 return 1;
14059 }
14060 }
14061 }
14062 }
14063 return 0;
14064}
14065
14066#ifdef GSCOPEP
14067static void
14068prop_reqgs(int ast)
14069{
14070 switch (A_TYPEG(ast)) {
14071 case A_ID:
14072 GSCOPEP(A_SPTRG(ast), 1);
14073 break;
14074 case A_SUBSCR:
14075 case A_SUBSTR:
14076 case A_UNOP:
14077 prop_reqgs(A_LOPG(ast));
14078 break;
14079 case A_MEM:
14080 prop_reqgs(A_PARENTG(ast));
14081 break;
14082 case A_BINOP:
14083 prop_reqgs(A_LOPG(ast));
14084 prop_reqgs(A_ROPG(ast));
14085 break;
14086 }
14087}
14088
14089static void
14090fixup_ident_bounds(int sptr)
14091{
14092 int dtype, numdim, i;
14093 ADSC *ad;
14094
14095 if (GSCOPEG(sptr)) {
14096 dtype = DTYPEG(sptr);
14097 if (DTY(dtype) != TY_ARRAY)
14098 return;
14099 ad = AD_DPTR(dtype);
14100 numdim = AD_NUMDIM(ad);
14101 prop_reqgs(AD_NUMELM(ad));
14102 prop_reqgs(AD_ZBASE(ad));
14103 for (i = 0; i < numdim; ++i) {
14104 prop_reqgs(AD_LWAST(ad, i));
14105 prop_reqgs(AD_UPAST(ad, i));
14106 prop_reqgs(AD_EXTNTAST(ad, i));
14107 prop_reqgs(AD_MLPYR(ad, i));
14108 }
14109 }
14110}
14111
14112void
14114{
14115 if (GSCOPEG(sptr)) {
14116 if (SDSCG(sptr)) {
14117 GSCOPEP(SDSCG(sptr), 1);
14118 }
14119 if (PTRVG(sptr)) {
14120 GSCOPEP(PTRVG(sptr), 1);
14121 }
14122 if (MIDNUMG(sptr)) {
14123 GSCOPEP(MIDNUMG(sptr), 1);
14124 }
14125 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
14126 fixup_ident_bounds(sptr);
14127 }
14128 }
14129}
14130
14131#endif
14132
14133static void
14134defer_iface(int iface, int dtype, int proc, int mem)
14135{
14136 int pass, len;
14137 iface_avail++;
14139 iface_base[iface_avail - 1].iface = iface;
14142 iface_base[iface_avail - 1].scope = SCOPEG(mem);
14143 iface_base[iface_avail - 1].internal = gbl.internal;
14144 /* Need to save which sem pass created this iface */
14146
14147 len = strlen(SYMNAME(iface)) + 1;
14148 NEW(iface_base[iface_avail - 1].iface_name, char, len);
14149 strcpy(iface_base[iface_avail - 1].iface_name, SYMNAME(iface));
14150
14153
14154 if (mem && STYPEG(mem) == ST_MEMBER) {
14156 pass = PASSG(mem);
14157 if (pass && DTYPEG(pass) != stsk->dtype) {
14158 /* assume dtype of pass argument is same as enclosed dtype.
14159 * We do this since PASS will get written to a module before
14160 * we can fix it after we've seen the procedure/interface.
14161 * If the pass argument differs from enclosed dtype, we will
14162 * catch it in do_iface().
14163 */
14164 DTYPEP(pass, stsk->dtype);
14165 }
14166
14167 } else {
14168 iface_base[iface_avail - 1].mem = 0;
14169 }
14170
14172 iface_base[iface_avail - 1].lineno = gbl.lineno;
14173}
14174
14175/** \brief This routine sets the PASS field in a procedure pointer for
14176 * semantic pass 0 prior to call to end_module().
14177 *
14178 * This is needed, otherwise we may incorrectly write the procedure pointer
14179 * module info without PASS set.
14180 */
14181static void
14183{
14184 int i, iface, mem;
14185 char *name;
14186
14187 if (sem.which_pass)
14188 return;
14189
14190 for (i = 0; i < iface_avail; i++) {
14191 mem = iface_base[i].mem;
14193
14194 if (!name || !mem)
14195 continue;
14196 iface = findByNameStypeScope(name, ST_PROC, 0);
14197 iface_base[i].stype = STYPEG(iface); /* need to save stype */
14198 if (iface && !PASSG(mem) && !NOPASSG(mem)) {
14199 int arg_sptr = aux.dpdsc_base[DPDSCG(iface)];
14200 PASSP(mem, arg_sptr);
14201 }
14202 }
14203}
14204
14205static void
14207{
14208 int len, tag, i, iface, proc, mem, dtype;
14209 int *dscptr;
14210 char *name;
14211
14212 for (i = 0; i < iface_avail; i++) {
14213 iface = iface_base[i].iface;
14214 proc = iface_base[i].proc;
14215 mem = iface_base[i].mem;
14218 if (!iface && mem && dtype && !NOPASSG(mem) &&
14219 strcmp(name, SYMNAME(sptr)) == 0) {
14220 iface = sptr;
14222 }
14223 if (iface && sptr && strcmp(name, SYMNAME(sptr)) == 0) {
14225 if (!PASSG(mem) && !NOPASSG(mem)) {
14226 dscptr = aux.dpdsc_base + DPDSCG(iface);
14227 PASSP(mem, *dscptr);
14228 } else if (PASSG(mem)) {
14229 int j = find_dummy_position(iface, PASSG(mem));
14230 if (j > 0)
14231 PASSP(mem, aux.dpdsc_base[DPDSCG(iface) + j - 1]);
14232 }
14233#ifdef CLASSG
14234 if (CLASSG(PASSG(mem))) {
14235 iface_base[i].pass_class = 1;
14236
14237 tag = DTYPEG(PASSG(mem));
14238 tag = DTY(tag + 3);
14239
14240 len = strlen(SYMNAME(tag)) + 1;
14241 NEW(iface_base[iface_avail - 1].tag_name, char, len);
14242 strcpy(iface_base[iface_avail - 1].tag_name, SYMNAME(tag));
14243 }
14244#endif
14245 }
14246 }
14247}
14248
14249/* Called during sem pass 0 at the end of the subroutine/function. We attempt
14250 * to share compatible procedure pointer dtypes found in argument descriptors.
14251 * This fixes a problem exhibited in the Whizard code where we perform an
14252 * argument check on a call to a forward referenced internal procedure. In
14253 * this case, the argument's DT_PROC dtype has not yet been seen.
14254 */
14255static void
14257{
14258
14259 int paramct, dpdsc, i;
14260
14261 if (sem.which_pass)
14262 return;
14263 proc_arginfo(gbl.currsub, &paramct, &dpdsc, NULL);
14264 for (i = 0; i < paramct; ++i) {
14265 int sptr = aux.dpdsc_base[dpdsc + i];
14266 if (is_procedure_ptr(sptr) && SCG(sptr) == SC_DUMMY) {
14267 char *symname = SYMNAME(sptr);
14268 int len = strlen(symname);
14269 int hash, hptr;
14270 HASH_ID(hash, symname, len);
14271 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
14272 if (is_procedure_ptr(hptr) && strcmp(symname, SYMNAME(hptr)) == 0) {
14273 if (hptr != sptr && test_scope(hptr) >= 0) {
14274 DTYPE d1 = DTYPEG(sptr);
14275 DTYPE d2 = DTYPEG(hptr);
14276 if (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), TRUE)) {
14277 DTYPEP(sptr, d2);
14278 break;
14279 }
14280 }
14281 }
14282 }
14283 }
14284 }
14285}
14286
14287static void
14288do_iface(int iface_state)
14289{
14290 int i;
14291 for (i = 0; i < iface_avail; i++) {
14292 _do_iface(iface_state, i);
14293 }
14294 if (iface_state) {
14295 iface_avail = 0;
14296 }
14297}
14298
14299static void
14301{
14302 /*
14303 * processing interfaces while in a module-contained subprogram;
14304 * need to process those interfaces which are not module procedures.
14305 */
14306 int i;
14307 int iface;
14308 assert(IN_MODULE, "must be in module", 0, ERR_Fatal);
14309 if (sem.interface && !get_seen_contains()) {
14310 /* in an interface block in a module specification, if the iface is from
14311 * this module, defer until the end of the module
14312 */
14313 for (i = 0; i < iface_avail; i++) {
14314 iface = iface_base[i].iface;
14315 if ((!iface || STYPEG(iface) == ST_UNKNOWN) && !sem.which_pass)
14316 continue;
14317 _do_iface(/*1*/ sem.which_pass, i);
14318 iface_base[i].iface = 0;
14319 }
14320 } else {
14321 if (!gbl.currsub) {
14322 /* IN_MODULE_SPEC */
14323 for (i = 0; i < iface_avail; i++) {
14324 iface = iface_base[i].iface;
14325 if (!iface)
14326 continue;
14327 switch (STYPEG(iface)) {
14328 case ST_UNKNOWN:
14329 case ST_MODPROC:
14330 continue;
14331 case ST_ALIAS:
14332 if (SCOPEG(iface) == gbl.currmod)
14333 continue;
14334 break;
14335 default:;
14336 }
14337 _do_iface(/*1*/ sem.which_pass, i);
14338 iface_base[i].iface = 0;
14339 }
14340 }
14341 for (i = 0; i < iface_avail; i++) {
14342 iface = iface_base[i].iface;
14343 if (iface) {
14344 int scp;
14345 scp = SCOPEG(iface);
14346 if (scp && (scp == gbl.currsub || scp == SCOPEG(gbl.currsub)) &&
14347 !INMODULEG(iface)) {
14348 _do_iface(1, i);
14349 iface_base[i].iface = 0;
14350 } else if (sem.which_pass) {
14351 switch (STYPEG(iface)) {
14352 case ST_MODPROC:
14353 case ST_ALIAS:
14354 break;
14355 default:
14356 if (scp == gbl.currmod) {
14358 iface_base[i].iface = 0;
14359 } else if (scp != gbl.currmod && NEEDMODG(scp)) {
14361 iface_base[i].iface = 0;
14362 }
14363 }
14364 } else if (gbl.currsub && scp &&
14365 (!INMODULEG(iface) || ABSTRACTG(iface))) {
14366 switch (STYPEG(iface)) {
14367 case ST_MODPROC:
14368 case ST_ALIAS:
14369 break;
14370 default:
14371 if (scp == ENCLFUNCG(gbl.currsub)) {
14372 _do_iface(1, i);
14373 iface_base[i].iface = 0;
14374 } else if (scp != SCOPEG(gbl.currsub)) {
14375 _do_iface(1, i);
14376 iface_base[i].iface = 0;
14377 }
14378 }
14379 }
14380 }
14381 }
14382 }
14383}
14384
14385/**
14386 * Called by _do_iface() as part of error clean-up. We need to clear the
14387 * next attempt to use an erroneous interface specified in the iface argument
14388 * starting at the "i + 1" element in iface_base.
14389 */
14390static void
14391clear_iface(int i, SPTR iface)
14392{
14393 int j;
14394
14395 for (j = i + 1; j < iface_avail; j++) {
14396 if (iface_base[j].iface &&
14397 sem_strcmp(SYMNAME(iface), SYMNAME(iface_base[j].iface)) == 0) {
14398 /* inhibit the next attempt to use the same interface */
14399 iface_base[j].iface = 0;
14400 }
14401 }
14402}
14403
14404static void
14405_do_iface(int iface_state, int i)
14406{
14407 SPTR sptr, orig, fval;
14408 int dpdsc, paramct = 0;
14409 LOGICAL pass_notfound;
14410 SPTR passed_object; /* passed-object dummy argument */
14411 SPTR iface = iface_base[i].iface;
14412 SPTR ptr_scope = iface_base[i].scope;
14413 const char *name = iface_base[i].iface_name;
14414 DTYPE dtype = iface_base[i].dtype;
14416 SPTR mem = iface_base[i].mem;
14417 int lineno = iface_base[i].lineno;
14418 LOGICAL class = iface_base[i].pass_class;
14419 const char *dt_name = iface_base[i].tag_name;
14420 SPTR proc_var = iface_base[i].proc_var;
14421 int internal = iface_base[i].internal;
14422
14423 if (!iface) {
14424 return;
14425 }
14426
14427 if (dtype > 0) {
14428 if (DTY(dtype) == TY_ARRAY) {
14429 dtype = DTY(dtype + 1);
14430 }
14431 if (DTY(dtype) == TY_PTR) {
14432 dtype = DTY(dtype+1);
14433 }
14434 if (DTY(dtype) != TY_PROC) {
14435 return;
14436 }
14437 }
14438
14439 if (ptr_scope && STYPEG(ptr_scope) != ST_MODULE &&
14440 ptr_scope != stb.curr_scope &&
14441 (gbl.internal <= 1 || (gbl.internal > 1 && gbl.outersub != ptr_scope))) {
14442 /* This procedure pointer is not in scope. So, we skip it to avoid
14443 * overwriting another dtype.
14444 */
14445 return;
14446 }
14447
14448 if (internal > 1 && gbl.internal != internal) {
14449 /* This procedure variable/pointer was declared in an internal procedure
14450 * that differs from the current procedure. So, skip it to avoid
14451 * overwriting it with another dtype.
14452 */
14453 return;
14454 }
14455
14456 if (proc) {
14457 DTYPEP(proc, DTYPEG(iface));
14458 }
14459 if (!STYPEG(iface)) {
14460 if (sem.which_pass) {
14461 SPTR hptr;
14462 char *symname = SYMNAME(iface);
14463 int len = strlen(symname);
14464 int hash;
14465 HASH_ID(hash, symname, len);
14466 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
14467 if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) {
14468 int scope = test_scope(hptr);
14469
14470 if (scope && scope <= test_scope(iface)) {
14471 iface = hptr;
14472 break;
14473 }
14474 }
14475 }
14476 if (!STYPEG(iface)) {
14477 /* Check to see if we saw this iface in the first pass.
14478 * If so, do not generate an error.
14479 */
14480 int j;
14481 for (j = 0; j < iface_avail; j++) {
14482 if (iface_base[j].sem_pass == 0 &&
14483 strcmp(iface_base[j].iface_name, name) == 0 &&
14484 iface_base[j].stype == ST_PROC) {
14485 return;
14486 }
14487 }
14488 orig = iface;
14489 goto iface_err;
14490 }
14491 }
14492 if (proc <= NOSYM)
14493 return;
14494 }
14495 if (strcmp(SYMNAME(iface), name) != 0)
14496 iface = getsymbol(name);
14497 if (sem.interface <= 1) {
14498 sptr = refsym(iface, OC_OTHER);
14499 } else {
14500 sptr = refsym_inscope(iface, OC_OTHER);
14501 }
14502 if (DTY(dtype) == TY_PROC && STYPEG(DTY(dtype + 2)) == ST_MEMBER) {
14503 iface = sptr;
14504 DTY(dtype + 2) = iface;
14505 }
14506 if ((!sem.which_pass || STYPEG(sptr)) &&
14507 (STYPEG(iface) != ST_ENTRY || sptr != FVALG(iface))) {
14508 iface = sptr;
14509 }
14510 orig = iface;
14511 switch (STYPEG(iface)) {
14512 case ST_IDENT:
14513 if (RESULTG(iface)) /* Interface not seen yet */
14514 return;
14515 goto iface_err;
14516 case ST_GENERIC:
14517 iface = GSAMEG(iface);
14519 case ST_INTRIN:
14520 case ST_PD:
14521 iface = iface_intrinsic(iface);
14522 if (!iface) {
14523 goto iface_err;
14524 }
14526 case ST_ENTRY:
14527 case ST_PROC:
14528 paramct = PARAMCTG(iface);
14529 dpdsc = DPDSCG(iface);
14530 break;
14531 case ST_MEMBER:
14532 if (DTY(DTYPEG(iface)) == TY_PTR) {
14533 /* Procedure pointer that's a component of a derived type. */
14534 break;
14535 }
14536 goto iface_err;
14537 default:
14538 iface_err:
14539 if (!STYPEG(iface) &&
14540 (!sem.which_pass || iface_state == 0 ||
14541 (IN_MODULE && !sem.seen_end_module))) {
14542/* Do not generate error on semantic pass 0. May not have seen the
14543 * entire module yet. Return only if we have seen an IMPORT stmt.
14544 */
14545 return;
14546 }
14547 error(155, 3, lineno, "Illegal procedure interface -", SYMNAME(orig));
14548 clear_iface(i, orig);
14549 return;
14550 }
14551 if (ELEMENTALG(orig) && !IS_INTRINSIC(STYPEG(orig)) &&
14552 POINTERG(proc_var)) {
14553 error(1010, ERR_Severe, lineno, SYMNAME(proc_var), CNULL);
14554 clear_iface(i, orig);
14555 }
14556 passed_object = 0;
14557 pass_notfound = mem && PASSG(mem);
14558 fval = FVALG(iface);
14559 if (paramct || fval) {
14560 SPTR *dscptr;
14561 int j;
14562 if (fval)
14563 dpdsc = ++aux.dpdsc_avl;
14564 else
14565 dpdsc = aux.dpdsc_avl;
14566 NEED(aux.dpdsc_avl + paramct, aux.dpdsc_base, int, aux.dpdsc_size,
14567 aux.dpdsc_size + paramct + 100);
14568 dscptr = aux.dpdsc_base + DPDSCG(iface);
14569 if (paramct && mem && !NOPASSG(mem) && !PASSG(mem)) {
14570 passed_object = *dscptr; /* passed-object default */
14571 }
14572 for (j = 0; j < paramct; j++) {
14573 SPTR arg = *dscptr++;
14574 aux.dpdsc_base[dpdsc + j] = arg;
14575 if (pass_notfound && sem_strcmp(SYMNAME(arg), SYMNAME(PASSG(mem))) == 0) {
14576 pass_notfound = FALSE;
14577 passed_object = arg;
14578 }
14579 }
14580 if (fval) {
14581 aux.dpdsc_base[dpdsc - 1] = fval;
14582 FUNCP(mem, TRUE);
14583 }
14584 aux.dpdsc_avl += paramct;
14585 } else {
14586 dpdsc = 0;
14587 }
14588 if (proc) {
14589 DTYPEP(proc, DTYPEG(iface));
14590 PARAMCTP(proc, paramct);
14591 DPDSCP(proc, dpdsc);
14592 FVALP(proc, fval);
14593 PUREP(proc, PUREG(iface));
14594 ELEMENTALP(proc, ELEMENTALG(iface));
14595 CFUNCP(proc, CFUNCG(iface));
14596 } else {
14597 /* dtype locates the TY_PROC data type record */
14598 if (mem && paramct == 0 && !NOPASSG(mem)) {
14599 error(155, 3, lineno, "NOPASS attribute must be present for",
14600 SYMNAME(mem));
14601 NOPASSP(mem, TRUE);
14602 passed_object = 0;
14603 }
14604 DTY(dtype + 1) = DTYPEG(iface);
14605 DTY(dtype + 2) = iface;
14606 DTY(dtype + 3) = paramct;
14607 DTY(dtype + 4) = dpdsc;
14608 DTY(dtype + 5) = fval;
14609 if (pass_notfound) {
14610 error(155, 3, lineno, "Passed-object dummy argument not found -",
14611 SYMNAME(PASSG(mem)));
14612 }
14613 if (passed_object && iface_state) {
14614 DTYPE dt;
14615 if (dt_name) {
14616 dt = DTYPEG(getsymbol(dt_name));
14617 } else
14618 dt = DTYPEG(passed_object);
14619 if (DTY(dt) != TY_DERIVED || DTY(dt + 3) == 0) {
14620 error(155, 3, lineno,
14621 "Passed-object dummy argument must be a derived type scalar -",
14622 SYMNAME(passed_object));
14623 } else {
14624 SPTR tdf = DTY(dt + 3);
14625 if (dt != ENCLDTYPEG(mem)) {
14626 error(155, 3, lineno,
14627 "Incompatible passed-object dummy argument for ",
14628 SYMNAME(iface));
14629 } else if (!SEQG(tdf) && !class) {
14630 error(155, 3, lineno,
14631 "Passed-object dummy argument is not polymorphic -",
14632 SYMNAME(passed_object));
14633 }
14634 if (POINTERG(passed_object) || ALLOCATTRG(passed_object))
14635 error(155, 3, lineno, "Passed-object dummy argument must not be "
14636 "POINTER or ALLOCATABLE -",
14637 SYMNAME(passed_object));
14638 }
14639 PASSP(mem, passed_object); /* default or specified */
14640 }
14641 }
14642}
14643
14644/** \brief Sets up type parameters used in parameterized derived types (PDTs)
14645 */
14646int
14647queue_type_param(int sptr, int dtype, int offset, int flag)
14648{
14649
14650 /* linked list of type parameters for a particular derived type */
14651 typedef struct tp {
14652 char *name; /* name of parameter */
14653 int dtype; /* derived type holding this type parameter */
14654 int offset; /* parameter's position in list parm list */
14655 struct tp *next; /* next record */
14656 } TP;
14657
14658 static TP *tp_queue = 0;
14659 TP *prev, *curr, *new_tp;
14660 char *c;
14661 int tag, parent, mem, i;
14662 int prevmem, firstuse, parentuse;
14663
14664 if (flag == 0) {
14665 /* init/clear entries */
14666 for (prev = curr = tp_queue; curr;) {
14667 FREE(curr->name);
14668 prev = curr;
14669 curr = curr->next;
14670 FREE(prev);
14671 }
14672 tp_queue = 0;
14673 return 1;
14674 } else if (flag == 1) {
14675 /* add entry */
14676 c = SYMNAME(sptr);
14677
14678 /* step 1 - check for duplicate type parameter in this type */
14679 for (curr = tp_queue; curr; curr = curr->next) {
14680 if (curr->dtype == dtype && strcmp(curr->name, c) == 0) {
14681 error(155, 3, gbl.lineno, "Duplicate type parameter -", c);
14682 return 0;
14683 }
14684 }
14685 /* step 2 - add type parameter to queue */
14686 NEW(new_tp, TP, 1);
14687 BZERO(new_tp, TP, 1);
14688
14689 NEW(new_tp->name, char, strlen(c) + 1);
14690 strcpy(new_tp->name, c);
14691 new_tp->dtype = dtype;
14692 new_tp->offset = offset;
14693 new_tp->next = tp_queue;
14694 tp_queue = new_tp;
14695 return 1;
14696 } else if (flag == 3) {
14697 tag = DTY(dtype + 3);
14698 parent = DTYPEG(PARENTG(tag));
14699
14700 if (parent) {
14702 if (i)
14703 return i;
14704 }
14705 for (curr = tp_queue; curr; curr = curr->next) {
14706 if (curr->dtype == dtype) {
14707 c = curr->name;
14708 if (strcmp(c, SYMNAME(sptr)) == 0)
14709 return curr->offset;
14710 }
14711 }
14712 return 0;
14713 } else if (flag == 2) {
14714 /* fill in dtype into type param fields, check parent type params,
14715 * check to make sure defined params have corresponding components
14716 * in the the dtype, and reorder (if necessary) params.
14717 */
14718 for (curr = tp_queue; curr; curr = curr->next) {
14719 if (curr->dtype == 0)
14720 curr->dtype = dtype;
14721 }
14722
14723 tag = DTY(dtype + 3);
14724 parent = DTYPEG(PARENTG(tag));
14725
14726 if (parent) {
14727 for (curr = tp_queue; curr; curr = curr->next) {
14728 if (curr->dtype == dtype) {
14729 c = curr->name;
14730 for (mem = DTY(parent + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14731 if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) {
14732 error(155, 3, gbl.lineno, "Duplicate type parameter "
14733 "(in parent type) -",
14734 c);
14735 }
14736 }
14737 }
14738 }
14739 }
14740
14741 for (curr = tp_queue; curr; curr = curr->next) {
14742 if (curr->dtype == dtype) {
14743 c = curr->name;
14744 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14745 if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), c) == 0) {
14746 KINDP(mem, curr->offset);
14747 break;
14748 }
14749 }
14750 if (mem <= NOSYM) {
14751 error(155, 3, gbl.lineno, "Missing type parameter specification -",
14752 c);
14753 }
14754 }
14755 }
14756
14757 /* check for extraneous kind type parameters */
14758
14759 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14760 if (!USEKINDG(mem) && KINDG(mem) == -1) {
14761 error(155, 3, gbl.lineno, "Kind type parameter component does not have "
14762 "a corresponding type parameter specifier -",
14763 SYMNAME(mem));
14764 }
14765 }
14766
14767/* For now, place length type parameters at the beginning of the dtype
14768 * to improve processing of them later.
14769 * Also fix up recursively typed components.
14770 */
14771
14772 firstuse = parentuse = 0;
14773 for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) {
14774 int bt;
14775 bt = DTYPEG(mem);
14776 if ((POINTERG(mem) || ALLOCATTRG(mem)) && DTY(bt) == TY_DERIVED) {
14777 bt = DTY(bt + 3);
14778 bt = BASETYPEG(bt);
14779 if (bt && bt == ENCLDTYPEG(mem)) {
14780 /* This is a recursively typed component. We need to set
14781 * this component's type to the enclosed type since this component
14782 * was added before the enclosed type was fully defined. Otherwise,
14783 * this component's type is incomplete and may not have all of its
14784 * components. Recursively typed components must have POINTER
14785 * attribute in F2003. In F2008, they can have POINTER or
14786 * ALLOCTABLE attribute.
14787 */
14788 DTYPEP(mem, bt);
14789 }
14790 }
14791 if (PARENTG(mem)) {
14792 parentuse = mem;
14793 } else if (!firstuse && !LENPARMG(mem) && USELENG(mem)) {
14794 firstuse = mem;
14795 } else if (firstuse && LENPARMG(mem)) {
14796 SYMLKP(prevmem, SYMLKG(mem));
14797 if (!parentuse) {
14798 SYMLKP(mem, DTY(dtype + 1));
14799 DTY(dtype + 1) = mem;
14800 } else {
14801 SYMLKP(mem, SYMLKG(parentuse));
14802 SYMLKP(parentuse, mem);
14803 }
14804 mem = SYMLKG(prevmem);
14805 continue;
14806 }
14807 prevmem = mem;
14808 mem = SYMLKG(mem);
14809 }
14810
14811 /* ditto with kind type parameters */
14812
14813 firstuse = parentuse = 0;
14814 for (prevmem = mem = DTY(dtype + 1); mem > NOSYM;) {
14815 if (PARENTG(mem)) {
14816 parentuse = mem;
14817 } else if (!firstuse && !LENPARMG(mem) && USEKINDG(mem) &&
14818 A_TYPEG(KINDASTG(mem)) != A_CNST &&
14819 A_TYPEG(KINDASTG(mem)) != A_ID) {
14820 firstuse = mem;
14821 } else if (firstuse && KINDG(mem) && !USEKINDG(mem) && !KINDASTG(mem)) {
14822 SYMLKP(prevmem, SYMLKG(mem));
14823 if (!parentuse) {
14824 SYMLKP(mem, DTY(dtype + 1));
14825 DTY(dtype + 1) = mem;
14826 } else {
14827 SYMLKP(mem, SYMLKG(parentuse));
14828 SYMLKP(parentuse, mem);
14829 }
14830 mem = SYMLKG(prevmem);
14831 continue;
14832 }
14833 prevmem = mem;
14834 mem = SYMLKG(mem);
14835 }
14836
14837 return 1;
14838 }
14839
14840 return 0;
14841}
14842
14843static void
14845{
14846
14847 int sptr, rslt;
14848
14849 if (!offset || *offset)
14850 return;
14851 if (A_TYPEG(ast) == A_ID) {
14852 sptr = A_SPTRG(ast);
14853 if (sptr) {
14854 rslt = queue_type_param(sptr, 0, 0, 3);
14855 if (!rslt && sem.stsk_depth && stsk == &STSK_ENT(0)) {
14856 rslt = get_kind_parm(sptr, stsk->dtype);
14857 }
14858 if (rslt) {
14859 *offset = rslt;
14860 return;
14861 }
14862 }
14863 }
14864}
14865
14866static int
14868{
14869 int offset;
14870 int sptr;
14871 int ast;
14872
14873 sptr = 0;
14874 switch (SST_IDG(stkp)) {
14875 case S_IDENT:
14876 sptr = SST_SYMG(stkp);
14877 break;
14878 case S_LVALUE:
14879 sptr = SST_LSYMG(stkp);
14880 break;
14881 case S_EXPR:
14882 ast = SST_ASTG(stkp);
14883 offset = 0;
14884 ast_visit(1, 1);
14886 ast_unvisit();
14887 return offset;
14888 }
14889 if (!sptr)
14890 return 0;
14891 /* Check to see if this is a kind type parameter */
14892 offset = queue_type_param(sptr, 0, 0, 3);
14893 if (!offset && INSIDE_STRUCT && stsk == &STSK_ENT(0) && stsk->type == 'd') {
14895 }
14896 if (offset)
14897 IGNOREP(sptr, TRUE); /* needed for "implicit none" */
14898 return offset;
14899}
14900
14901static int
14903{
14904 int rslt, mem;
14905
14906 if (DTY(dtype) != TY_DERIVED)
14907 return 0;
14908
14909 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14910 if (PARENTG(mem)) {
14911 rslt = get_kind_parm(sptr, DTYPEG(mem));
14912 if (rslt)
14913 return rslt;
14914 }
14915 if (!USEKINDG(mem) && KINDG(mem) &&
14916 strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0)
14917 return KINDG(mem);
14918 }
14919
14920 return 0;
14921}
14922
14923static int
14925{
14926 int rslt, mem;
14927
14928 if (DTY(dtype) != TY_DERIVED)
14929 return 0;
14930
14931 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14932 if (PARENTG(mem)) {
14933 rslt = get_kind_parm(sptr, DTYPEG(mem));
14934 if (rslt)
14935 return rslt;
14936 }
14937 if (!USEKINDG(mem) && !LENPARMG(mem) && KINDG(mem) &&
14938 strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
14939 return KINDG(mem);
14940 }
14941 }
14942
14943 return 0;
14944}
14945
14946/** \brief search a derived type for a kind type parameter with a specified
14947 * name.
14948 *
14949 * \param np is the name we're search for
14950 * \param dtype is the derived type record that we are searching
14951 *
14952 * \return integer > 0 for the parameter number, else 0 if not found.
14953 */
14954int
14956{
14957 int rslt, mem;
14958
14959 if (DTY(dtype) != TY_DERIVED)
14960 return 0;
14961
14962 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14963 if (PARENTG(mem)) {
14964 rslt = get_kind_parm_by_name(np, DTYPEG(mem));
14965 if (rslt)
14966 return rslt;
14967 }
14968 if (!USEKINDG(mem) && KINDG(mem) && strcmp(SYMNAME(mem), np) == 0)
14969 return KINDG(mem);
14970 }
14971
14972 return 0;
14973}
14974
14975/** \brief search derived type for a type parameter in the same position as
14976 * specified by offset.
14977 *
14978 * \param offset is the desired parameter position
14979 * \param dtype is the derived type record to search in
14980 *
14981 * \return symbol table pointer of the parameter component in the derived
14982 * type; else 0 if not found.
14983 */
14984int
14986{
14987 int rslt, mem;
14988
14989 if (DTY(dtype) != TY_DERIVED)
14990 return 0;
14991
14992 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
14993 if (PARENTG(mem)) {
14994 rslt = get_parm_by_number(offset, DTYPEG(mem));
14995 if (rslt)
14996 return rslt;
14997 }
14998 if (!USEKINDG(mem) && KINDG(mem) == offset)
14999 return mem;
15000 }
15001 return 0;
15002}
15003
15004/** \brief search a derived type for a kind or length type parameter with a
15005 * specified name.
15006 *
15007 * \param np is the name we're search for
15008 * \param dtype is the derived type record that we are searching
15009 *
15010 * \return integer > 0 for the parameter number, else 0 if not found.
15011 */
15012int
15014{
15015 int rslt, mem;
15016
15017 if (DTY(dtype) != TY_DERIVED)
15018 return 0;
15019
15020 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15021 if (PARENTG(mem)) {
15022 rslt = get_parm_by_name(np, DTYPEG(mem));
15023 if (rslt)
15024 return rslt;
15025 }
15026 if (!USEKINDG(mem) && KINDG(mem) && strcmp(np, SYMNAME(mem)) == 0)
15027 return mem;
15028 }
15029 return 0;
15030}
15031
15032/** Should be called when we parse ENDTYPE. This function goes
15033 * through a derived type's members and makes sure there are
15034 * no length type parameters in the initialization part of a
15035 * member.
15036 */
15037static void
15039{
15040 int mem;
15041
15042 if (DTY(dtype) == TY_ARRAY)
15043 dtype = DTY(dtype + 1);
15044
15045 if (DTY(dtype) != TY_DERIVED)
15046 return;
15047
15048 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15049 if (PARENTG(mem)) {
15051 }
15052 if (INITKINDG(mem) && PARMINITG(mem) &&
15053 !chk_kind_parm_expr(PARMINITG(mem), dtype, 0, 1)) {
15054 error(155, 3, gbl.lineno, "Initialization must be a constant"
15055 " expression for component",
15056 SYMNAME(mem));
15057 }
15058 }
15059}
15060
15061int
15062chk_kind_parm_expr(int ast, int dtype, int flag, int strict_flag)
15063{
15064 int sptr, offset, rslt, i;
15065
15066 if (!ast)
15067 return 0;
15068
15069 switch (A_TYPEG(ast)) {
15070 case A_INTR:
15071 switch (A_OPTYPEG(ast)) {
15072 case I_INT1:
15073 case I_INT2:
15074 case I_INT4:
15075 case I_INT8:
15076 case I_INT:
15077 i = A_ARGSG(ast);
15078 return chk_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag, strict_flag);
15079 }
15080 break;
15081 case A_CONV:
15082 return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
15083 case A_CNST:
15084 return 1;
15085 case A_ID:
15086 sptr = A_SPTRG(ast);
15087 offset = (!strict_flag) ? get_kind_parm(sptr, dtype)
15089 if (flag && !offset && (!strict_flag || !get_kind_parm(sptr, dtype))) {
15090 /* we might be in the middle of a derived type definition, so see if
15091 * there's a match in the type parameter queue.
15092 */
15093 offset = queue_type_param(sptr, 0, 0, 3);
15094 }
15095 if (!offset)
15096 return 0;
15097 IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
15098 KINDP(sptr, offset);
15099 return offset;
15100 case A_UNOP:
15101 return chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
15102 case A_BINOP:
15103 rslt = chk_kind_parm_expr(A_LOPG(ast), dtype, flag, strict_flag);
15104 if (!rslt)
15105 return 0;
15106 rslt = chk_kind_parm_expr(A_ROPG(ast), dtype, flag, strict_flag);
15107 if (!rslt)
15108 return 0;
15109 return rslt;
15110 }
15111
15112 return 0;
15113}
15114
15115static int
15116has_kind_parm_expr(int ast, int dtype, int flag)
15117{
15118
15119 int sptr, offset, rslt, i;
15120
15121 if (!ast)
15122 return 0;
15123
15124 switch (A_TYPEG(ast)) {
15125 case A_INTR:
15126 switch (A_OPTYPEG(ast)) {
15127 case I_INT1:
15128 case I_INT2:
15129 case I_INT4:
15130 case I_INT8:
15131 case I_INT:
15132 i = A_ARGSG(ast);
15133 return has_kind_parm_expr(ARGT_ARG(i, 0), dtype, flag);
15134 }
15135 break;
15136 case A_CONV:
15137 return has_kind_parm_expr(A_LOPG(ast), dtype, flag);
15138 case A_CNST:
15139 return 0;
15140 case A_ID:
15141 sptr = A_SPTRG(ast);
15143 if (flag && !offset) {
15144 /* we might be in the middle of a derived type definition, so see if
15145 * there's a match in the type parameter queue.
15146 */
15147 offset = queue_type_param(sptr, 0, 0, 3);
15148 }
15149 if (!offset)
15150 return 0;
15151 IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
15152 KINDP(sptr, offset);
15153 return offset;
15154 case A_UNOP:
15155 return has_kind_parm_expr(A_LOPG(ast), dtype, flag);
15156 case A_BINOP:
15157 rslt = has_kind_parm_expr(A_LOPG(ast), dtype, flag);
15158 if (rslt)
15159 return rslt;
15160 rslt = has_kind_parm_expr(A_ROPG(ast), dtype, flag);
15161 return rslt;
15162 }
15163
15164 return 0;
15165}
15166
15167static int
15169{
15170
15171 int sptr, mem, rslt;
15172
15173 if (!ast)
15174 return 0;
15175
15176 switch (A_TYPEG(ast)) {
15177 case A_ID:
15178 sptr = A_SPTRG(ast);
15179 rslt = 0;
15180 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15181 if (PARENTG(mem)) {
15182 rslt = chk_asz_deferlen(ast, DTYPEG(mem));
15183 if (rslt < 0)
15184 return rslt;
15185 continue;
15186 }
15187 if (strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
15188 rslt = sptr = mem;
15189 break;
15190 }
15191 }
15192 if (rslt) {
15193 if (DEFERLENG(sptr))
15194 return -1;
15195 else if (ASZG(sptr))
15196 return -2;
15197 }
15198 break;
15199 case A_BINOP:
15200 rslt = chk_asz_deferlen(A_LOPG(ast), dtype);
15201 if (rslt != 0) {
15202 return rslt;
15203 }
15204 rslt = chk_asz_deferlen(A_ROPG(ast), dtype);
15205 if (rslt != 0) {
15206 return rslt;
15207 }
15208 }
15209 return 0;
15210}
15211
15212static int
15214{
15215 int rslt, mem;
15216
15217 if (DTY(dtype) != TY_DERIVED)
15218 return 0;
15219
15220 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15221 if (PARENTG(mem)) {
15222 rslt = get_len_parm(sptr, DTYPEG(mem));
15223 if (rslt)
15224 return rslt;
15225 }
15226 if (LENPARMG(mem) && !USEKINDG(mem) && KINDG(mem) &&
15227 strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0)
15228 return KINDG(mem);
15229 }
15230
15231 return 0;
15232}
15233
15234int
15235chk_len_parm_expr(int ast, int dtype, int flag)
15236{
15237 int sptr, offset, rslt;
15238
15239 if (!ast)
15240 return 0;
15241
15242 switch (A_TYPEG(ast)) {
15243
15244 case A_CNST:
15245 return 1;
15246 case A_ID:
15247 sptr = A_SPTRG(ast);
15249 if (flag && !offset) {
15250 /* we might be in the middle of a derived type definition, so see if
15251 * there's a match in the type parameter queue.
15252 */
15253 offset = queue_type_param(sptr, 0, 0, 3);
15254 }
15255 if (offset) {
15256 IGNOREP(sptr, TRUE); /* prevent "implicit none" errors */
15257 if (ST_ISVAR(STYPEG(sptr)) || STYPEG(sptr) == ST_IDENT) {
15258 /* This symbol is a len parameter place holder. */
15259 LENPHP(sptr, 1);
15260 }
15261 }
15262 return offset;
15263 case A_UNOP:
15264 return chk_len_parm_expr(A_LOPG(ast), dtype, flag);
15265 case A_BINOP:
15266 rslt = chk_len_parm_expr(A_LOPG(ast), dtype, flag);
15267 if (!rslt)
15268 return 0;
15269 rslt = chk_len_parm_expr(A_ROPG(ast), dtype, flag);
15270 if (!rslt)
15271 return 0;
15272 return rslt;
15273 }
15274
15275 return 0;
15276}
15277
15278#ifdef FLANG_SEMANT_UNUSED
15279static int
15280fix_kind_parm_expr(int ast, int dtype, int offset, int value)
15281{
15282 int sptr, newast;
15283
15284 switch (A_TYPEG(ast)) {
15285
15286 case A_CNST:
15287 break;
15288 case A_ID:
15289 sptr = A_SPTRG(ast);
15290 if (KINDG(sptr) == offset) {
15292 }
15293 break;
15294 case A_UNOP:
15295 newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value);
15296 A_LOPP(ast, newast);
15297 break;
15298 case A_BINOP:
15299 newast = fix_kind_parm_expr(A_LOPG(ast), dtype, offset, value);
15300 A_LOPP(ast, newast);
15301 newast = fix_kind_parm_expr(A_ROPG(ast), dtype, offset, value);
15302 A_ROPP(ast, newast);
15303 break;
15304 }
15305
15306 return ast;
15307}
15308#endif
15309
15310int
15312{
15313 int rslt, mem;
15314
15315 if (DTY(dtype) != TY_DERIVED)
15316 return 0;
15317
15318 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15319 if (PARENTG(mem)) {
15320 rslt = get_len_set_parm_by_name(np, DTYPEG(mem), val);
15321 if (rslt)
15322 return rslt;
15323 }
15324 if (LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
15325 strcmp(SYMNAME(mem), np) == 0) {
15326 *val = LENG(mem);
15327 return KINDG(mem);
15328 }
15329 }
15330
15331 return 0;
15332}
15333
15334int
15335cmp_len_parms(int ast1, int ast2)
15336{
15337
15338 int sptr1, sptr2;
15339 int rslt;
15340
15341 if (A_TYPEG(ast1) != A_TYPEG(ast2))
15342 return 0;
15343
15344 switch (A_TYPEG(ast1)) {
15345
15346 case A_CNST:
15347 if (CONVAL2G(A_SPTRG(ast1)) == CONVAL2G(A_SPTRG(ast2)))
15348 return 1;
15349 return 0;
15350 case A_ID:
15351 sptr1 = A_SPTRG(ast1);
15352 sptr2 = A_SPTRG(ast2);
15353 return sptr1 == sptr2;
15354 case A_UNOP:
15355 if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2))
15356 return 0;
15357 return cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2));
15358 case A_BINOP:
15359 if (A_OPTYPEG(ast1) != A_OPTYPEG(ast2))
15360 return 0;
15361 rslt = cmp_len_parms(A_LOPG(ast1), A_LOPG(ast2));
15362 if (!rslt)
15363 return 0;
15364 rslt = cmp_len_parms(A_ROPG(ast1), A_ROPG(ast2));
15365 if (!rslt)
15366 return 0;
15367 return 1;
15368 }
15369
15370 return 0;
15371}
15372
15373/** \brief Store dtypes of parameterized derived types in which a parameter was
15374 explicitly declared (as opposed to using just the default values).
15375 */
15376int
15377defer_pt_decl(int dtype, int flag)
15378{
15379 typedef struct ptList {
15380 int dtype;
15381 struct ptList *next;
15382 } PL;
15383
15384 static PL *pl = NULL;
15385 PL *curr, *newpl, *prev;
15386 int rslt;
15387
15388 rslt = 0;
15389 if (flag == 0 && !sem.interface && sem.which_pass) {
15390 /* delete all entries from list */
15391 for (curr = pl; curr;) {
15392 prev = curr;
15393 curr = curr->next;
15394 FREE(prev);
15395 rslt = 1;
15396 }
15397 pl = NULL;
15398 } else if (flag == 1 && !sem.which_pass) {
15399 /* add entry */
15400 NEW(newpl, PL, 1);
15401 newpl->dtype = dtype;
15402 newpl->next = pl;
15403 pl = newpl;
15404 rslt = 1;
15405 } else if (flag == 2 && sem.which_pass) {
15406 /* is this list non-empty? */
15407 rslt = (pl != NULL);
15408 }
15409
15410 return rslt;
15411}
15412
15413static void
15415 int flag)
15416{
15417 typedef struct parmList {
15418 int offset;
15419 int value;
15420 char *name;
15421 int ast;
15422 int is_defer_len;
15423 int is_assume_sz;
15424 struct parmList *next;
15425 } PL;
15426
15427 static PL *pl = NULL;
15428 PL *curr, *newpl, *prev;
15429 int i;
15430 int rslt;
15431 int flag2;
15432
15433 rslt = 0;
15434 if (flag == 0) {
15435 /* delete all entries from list */
15436 for (curr = pl; curr;) {
15437 prev = curr;
15438 curr = curr->next;
15439 FREE(prev);
15440 rslt = 1;
15441 }
15442 pl = NULL;
15443 } else if (flag == 1) {
15444 /* add entry */
15445 NEW(newpl, PL, 1);
15446 newpl->offset = offset;
15447 newpl->value = value;
15448 newpl->name = name;
15449 newpl->ast = ast;
15450 newpl->is_defer_len = sem.param_defer_len;
15451 newpl->is_assume_sz = sem.param_assume_sz;
15452 newpl->next = pl;
15453 pl = newpl;
15454 rslt = 1;
15455 } else if (flag == 2) {
15456 /* process type params */
15457 if (DTY(dtype) != TY_DERIVED) {
15458 return;
15459 }
15460 for (curr = pl; curr; curr = curr->next) {
15461 rslt = 1;
15462 if (sem.new_param_dt == 0) {
15464 }
15465 if (curr->is_defer_len) {
15466 flag2 = -1;
15467 } else if (curr->is_assume_sz) {
15468 flag2 = -2;
15469 } else
15470 flag2 = 0;
15471 if (!curr->name) {
15472 i = put_kind_type_param(sem.new_param_dt, curr->offset, curr->value,
15473 curr->ast, flag2);
15474 if (!i) {
15475 error(155, 3, gbl.lineno, "Too many type parameter specifiers", NULL);
15476 }
15477 } else {
15478 i = get_kind_parm_by_name(curr->name, sem.new_param_dt);
15479 if (i) {
15480 put_kind_type_param(sem.new_param_dt, i, curr->value, curr->ast,
15481 flag2);
15482 } else {
15483 error(155, 3, gbl.lineno, "Undefined type parameter", curr->name);
15484 }
15485 }
15486 }
15488 }
15489}
15490
15491void
15492put_default_kind_type_param(int dtype, int flag, int flag2)
15493{
15494
15495 typedef struct dtyList {
15496 int dtype;
15497 struct dtyList *next;
15498 } DL;
15499
15500 static DL *dl = NULL;
15501 DL *curr, *newdl, *prev;
15502
15503 int mem_dtype, offset, val, mem;
15504
15505 if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype))
15506 return;
15507 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15508 mem_dtype = DTYPEG(mem);
15509 if (PARENTG(mem)) {
15510 NEW(newdl, DL, 1);
15511 BZERO(newdl, DL, 1);
15512 newdl->dtype = dtype;
15513 newdl->next = dl;
15514 dl = newdl;
15515 put_default_kind_type_param(mem_dtype, 1, flag2);
15516 } else if (!SETKINDG(mem) && !USEKINDG(mem) && (offset = KINDG(mem)) &&
15517 (val = PARMINITG(mem))) {
15518 put_kind_type_param(dtype, offset, val, 0, flag2);
15519 for (curr = dl; curr; curr = curr->next) {
15520 put_kind_type_param(curr->dtype, offset, val, 0, flag2);
15521 }
15522 }
15523 }
15524 if (!flag) {
15525 for (curr = dl; curr;) {
15526 prev = curr;
15527 curr = curr->next;
15528 FREE(prev);
15529 }
15530 dl = NULL;
15531 }
15533}
15534
15535void
15537{
15538
15539 typedef struct dtyList {
15540 DTYPE dtype;
15541 struct dtyList *next;
15542 } DL;
15543
15544 typedef struct char_info {
15545 DTYPE dtype;
15546 int situation;
15547 int ast;
15548 struct char_info *next;
15549 } CL;
15550
15551 static DL *dl = NULL;
15552 DL *curr, *newdl, *prev;
15553
15554 static CL *cl = NULL;
15555 CL *ccl, *newcl, *pcl;
15556
15557 int mem;
15558
15559 if (flag == 2) {
15560 for (pcl = ccl = cl; ccl;) {
15561 ccl = ccl->next;
15562 FREE(pcl);
15563 pcl = ccl;
15564 }
15565 cl = NULL;
15566 return;
15567 }
15568
15569 if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype))
15570 return;
15571
15572 if (!sem.new_param_dt) {
15574 }
15575
15576 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15577 DTYPE mem_dtype = DTYPEG(mem);
15578 if (PTRVG(mem) || DESCARRAYG(mem)) {
15579 continue;
15580 }
15581 if (PARENTG(mem)) {
15582 NEW(newdl, DL, 1);
15583 BZERO(newdl, DL, 1);
15584 newdl->dtype = dtype;
15585 newdl->next = dl;
15586 dl = newdl;
15587 put_length_type_param(mem_dtype, flag + 1);
15588 }
15589
15590 if (DTY(mem_dtype) == TY_CHAR || DTY(mem_dtype) == TY_NCHAR)
15591 {
15592 int ast = DTY(mem_dtype + 1);
15593 if (flag >= 3)
15594 continue;
15595 for (ccl = cl; ccl; ccl = ccl->next) {
15596 if (ccl->dtype == mem_dtype && ccl->situation) {
15597 goto do_assume_sz;
15598 }
15599 }
15600 if (A_TYPEG(ast) != A_CNST) {
15602 if (i > 0) {
15603 if (A_TYPEG(i) == A_CNST) {
15604 int con = CONVAL2G(A_SPTRG(i));
15605 if (con < 0) {
15607 if (i == -1 || i == -2) {
15608 i = sym_get_scalar(SYMNAME(mem), "len", DT_INT);
15609 DTY(mem_dtype + 1) = mk_id(i);
15610 do_assume_sz:
15611 LENP(mem, ast);
15612 NEW(newcl, CL, 1);
15613 newcl->dtype = mem_dtype;
15614 newcl->situation = 2;
15615 newcl->ast = LENG(mem);
15616 newcl->next = cl;
15617 cl = newcl;
15618 ALLOCATTRP(mem, 1);
15619 TPALLOCP(mem, 1);
15620 goto shared_alloc_char;
15621 } else {
15622 interr("put_length_type_param: unexpected len type param", 0,
15623 3);
15624 LENP(mem, astb.i0);
15625 DTY(mem_dtype + 1) = astb.i0;
15626 }
15627
15628 } else {
15629 DTY(mem_dtype + 1) = i;
15630 }
15631 } else if (A_TYPEG(i) != A_CNST) {
15632 DTY(mem_dtype + 1) = i;
15633 LENP(mem, i);
15634
15635 shared_alloc_char:
15636 if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15637 TPALLOCP(mem, 1);
15638 ALLOCP(mem, TRUE);
15639 USELENP(mem, TRUE);
15640
15641 DTYPEP(mem,
15642 (DTY(mem_dtype) == TY_CHAR) ? DT_DEFERCHAR : DT_DEFERNCHAR);
15643 if (SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) {
15644 ENCLDTYPEP(mem, dtype);
15645 SDSCP(mem, sym_get_sdescr(mem, 0));
15647 }
15648 ALLOCDESCP(mem, TRUE);
15649 } else
15650 DTY(mem_dtype + 1) = i;
15651 }
15652 }
15653 }
15654
15655 if (DTY(mem_dtype) == TY_ARRAY && !DESCARRAYG(mem)) {
15656 int numdim, i, num_ast;
15657 ADSC *ad;
15658
15659 mem_dtype = dup_array_dtype(mem_dtype);
15660 DTYPEP(mem, mem_dtype);
15661
15662 ad = AD_DPTR(mem_dtype);
15663 numdim = AD_NUMDIM(ad);
15664 num_ast = 0;
15665
15666 for (i = 0; i < numdim; i++) {
15667 int lb, ub, bndast, con;
15668
15669 if (SDSCG(mem) != 0) {
15670 /* replace the descriptor in the bounds expressions with the
15671 descriptor created for mem in get_parameterized_dt() */
15672 replace_sdsc_in_bounds(SDSCG(mem), ad, i);
15673 }
15674
15675 lb = bndast = AD_LWAST(ad, i);
15676 if (bndast != 0 && A_ALIASG(bndast) == 0) {
15677 int ast = chk_kind_parm_set_expr(bndast, dtype);
15678 if (ast > 0) {
15679 lb = AD_LWAST(ad, i) = ast;
15680 if (A_TYPEG(ast) != A_CNST) {
15681 if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15682 TPALLOCP(mem, TRUE);
15683 ALLOCP(mem, TRUE);
15684 USELENP(mem, TRUE);
15685 ADJARRP(mem, TRUE);
15686 if (!SDSCG(mem)) {
15687 ENCLDTYPEP(mem, dtype);
15690 }
15691 }
15692 }
15693 }
15694
15695 ub = bndast = AD_UPAST(ad, i);
15696 con = USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP
15697 ? 0
15698 : chk_asz_deferlen(bndast, dtype);
15699 if (con == -1) {
15700 USEDEFERP(mem, TRUE);
15701 if (A_TYPEG(ub) == A_BINOP && flag < 3) {
15702 continue;
15703 }
15704 }
15705 if (!USEDEFERG(mem) && A_TYPEG(ub) == A_BINOP) {
15706 ub = mk_stmt(A_BINOP, 0);
15707 A_OPTYPEP(ub, A_OPTYPEG(bndast));
15708 A_LOPP(ub, A_LOPG(bndast));
15709 A_ROPP(ub, A_ROPG(bndast));
15710 A_DTYPEP(ub, A_DTYPEG(bndast));
15711 bndast = AD_UPAST(ad, i) = ub;
15712 }
15713 if (bndast != 0 && A_ALIASG(bndast) == 0) {
15714 int ast = chk_kind_parm_set_expr(bndast, dtype);
15715 if (ast <= 0 || A_TYPEG(ast) == A_CNST) {
15716 int con2 = ast <= 0 ? ast : CONVAL2G(A_SPTRG(ast));
15717 if (con2 <= 0 && (con == -1 || con == -2))
15718 ast = bndast;
15719 }
15720
15721 if (ast > 0) {
15722 ub = AD_UPAST(ad, i) = ast;
15723 if (USELENG(mem)) {
15724 if (!ALLOCG(mem) && !ALLOCATTRG(mem) && !POINTERG(mem))
15725 TPALLOCP(mem, TRUE);
15726 ALLOCP(mem, TRUE);
15727 USELENP(mem, TRUE);
15728 ADJARRP(mem, TRUE);
15729 if (!SDSCG(mem) || STYPEG(SDSCG(mem)) != ST_MEMBER) {
15730 ENCLDTYPEP(mem, dtype);
15733 }
15734
15735 if (USEDEFERG(mem)) {
15736 int mem2, mem3;
15737 int mem1 = SYMLKG(mem);
15738 int sdsc_mem = mem1;
15739 if (sdsc_mem == MIDNUMG(mem) || PTRVG(sdsc_mem)) {
15740 sdsc_mem = mem2 = SYMLKG(sdsc_mem);
15741 }
15742 if (PTRVG(sdsc_mem) || !DESCARRAYG(sdsc_mem)) {
15743 sdsc_mem = mem3 = SYMLKG(sdsc_mem);
15744 }
15745
15746 if (DESCARRAYG(sdsc_mem)) {
15747 if (mem1 > NOSYM)
15748 USEDEFERP(mem1, TRUE);
15749 if (mem2 > NOSYM)
15750 USEDEFERP(mem2, TRUE);
15751 if (mem3 > NOSYM)
15752 USEDEFERP(mem3, TRUE);
15753 }
15754 }
15755 }
15756 }
15757 }
15758 AD_LWAST(ad, i) = mk_bnd_int(lb);
15759 AD_UPAST(ad, i) = mk_bnd_int(ub);
15760 bndast =
15762 bndast = mk_binop(OP_ADD, bndast, mk_isz_cval(1, astb.bnd.dtype),
15763 astb.bnd.dtype);
15764
15765 if (!SDSCG(mem)) {
15766 AD_EXTNTAST(ad, i) = bndast;
15767 } else {
15768 AD_EXTNTAST(ad, i) = get_extent(SDSCG(mem), i);
15769 AD_MLPYR(ad, i) = get_local_multiplier(SDSCG(mem), i);
15770 }
15771
15772 if (!num_ast) {
15773 num_ast = bndast;
15774 } else {
15775 num_ast = mk_binop(OP_MUL, num_ast, bndast, astb.bnd.dtype);
15776 }
15777 }
15778 if (num_ast) {
15779 ADD_NUMELM(mem_dtype) = num_ast;
15780 }
15781 }
15782 }
15783 if (flag > 0) {
15784 for (curr = dl; curr;) {
15785 prev = curr;
15786 curr = curr->next;
15787 FREE(prev);
15788 }
15789 dl = NULL;
15790 }
15792}
15793
15794/* Replace sdsc in the ASTs for each bound */
15795static void
15796replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i)
15797{
15798 int ast = replace_sdsc_in_ast(sdsc, AD_LWAST(ad, i));
15799 if (ast != 0) {
15800 AD_LWAST(ad, i) = ast;
15801 }
15802 ast = replace_sdsc_in_ast(sdsc, AD_LWBD(ad, i));
15803 if (ast != 0) {
15804 AD_LWBD(ad, i) = ast;
15805 }
15806 ast = replace_sdsc_in_ast(sdsc, AD_UPAST(ad, i));
15807 if (ast != 0) {
15808 AD_UPAST(ad, i) = ast;
15809 }
15810 ast = replace_sdsc_in_ast(sdsc, AD_UPBD(ad, i));
15811 if (ast != 0) {
15812 AD_UPBD(ad, i) = ast;
15813 }
15814}
15815
15816/* If there is an ID node in the ast tree that matches the name of this
15817 descriptor,
15818 replace it with the sdsc symbol. Return 0 if unchanged.
15819 */
15820static int
15822{
15823 int lop, rop, sptr;
15824 switch (A_TYPEG(ast)) {
15825 case A_ID:
15826 sptr = A_SPTRG(ast);
15827 if (DESCARRAYG(sptr) && sdsc != sptr &&
15828 strcmp(SYMNAME(sdsc), SYMNAME(sptr)) == 0) {
15829 return mk_id(sdsc);
15830 }
15831 break;
15832 case A_BINOP:
15833 lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast));
15834 rop = replace_sdsc_in_ast(sdsc, A_ROPG(ast));
15835 if (lop != 0 || rop != 0) {
15836 return mk_binop(A_OPTYPEG(ast), lop != 0 ? lop : A_LOPG(ast),
15837 rop != 0 ? rop : A_ROPG(ast), A_DTYPEG(ast));
15838 }
15839 break;
15840 case A_SUBSCR:
15841 lop = replace_sdsc_in_ast(sdsc, A_LOPG(ast));
15842 if (lop != 0) {
15843 return mk_subscr_copy(lop, A_ASDG(ast), A_DTYPEG(ast));
15844 }
15845 break;
15846 }
15847 return 0;
15848}
15849
15850int
15852{
15853 int mem, i;
15854
15855 if (DTY(dtype) != TY_DERIVED)
15856 return 0;
15857
15858 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15859 if (PARENTG(mem)) {
15860 i = get_len_parm_by_number(num, DTYPEG(PARENTG(mem)), flag);
15861 if (i)
15862 return i;
15863 }
15864 if (LENPARMG(mem) == num) {
15865 if (!flag || DEFERLENG(mem) || ASZG(mem)) {
15866 return mk_id(mem);
15867 } else {
15868 INT val[2];
15869 val[0] = 0;
15870 val[1] = PARMINITG(mem);
15871 return mk_cnst(getcon(val, DT_INT));
15872 }
15873 }
15874 }
15875
15876 return 0;
15877}
15878
15879/** \brief Return 0 if there's at least one length type parameter that is not
15880 assumed. Otherwise return 1.
15881 */
15882int
15884{
15885
15886 int i, mem;
15887
15888 if (DTY(dtype) != TY_DERIVED)
15889 return 0;
15890
15891 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15892 if (PARENTG(mem)) {
15893 i = all_len_parms_assumed(DTYPEG(PARENTG(mem)));
15894 if (!i)
15895 return 0;
15896 }
15897 if (LENPARMG(mem) && !ASZG(mem))
15898 return 0;
15899 }
15900 return 1;
15901}
15902
15903static void
15905{
15906 int mem, mem_dtype;
15907
15908 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15909 mem_dtype = DTYPEG(mem);
15910 if (PARENTG(mem)) {
15911 check_kind_type_param(mem_dtype);
15912 }
15913 if (!SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) && !LENPARMG(mem) &&
15914 !PARMINITG(mem)) {
15915 error(155, 3, gbl.lineno,
15916 "Missing constant value for kind type parameter", SYMNAME(mem));
15917 }
15918 }
15919}
15920
15921LOGICAL
15922put_kind_type_param(DTYPE dtype, int offset, int value, int expr, int flag)
15923{
15924 int mem;
15925 LOGICAL found = FALSE;
15926
15927 if (DTY(dtype) != TY_DERIVED) {
15928 return FALSE;
15929 }
15930
15931 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
15932 DTYPE mem_dtype = DTYPEG(mem);
15933 if (PARENTG(mem)) {
15934 if (is_pdt_dtype(mem_dtype)) {
15935 found = put_kind_type_param(mem_dtype, offset, value, expr, flag);
15936 }
15937 } else if (USEKINDG(mem) && KINDG(mem) == offset) {
15938 if (expr && A_TYPEG(expr) != A_CNST) {
15939 error(155, ERR_Severe, gbl.lineno,
15940 "Kind type parameter value must be a compile-time constant"
15941 " for component",
15942 SYMNAME(mem));
15943 }
15944 if (DTY(mem_dtype) != TY_ARRAY) {
15945 int ast;
15946 DTYPE out_dtype;
15947 int ty;
15948 if (DT_ISINT(mem_dtype))
15949 ty = TY_INT;
15950 else if (DT_ISREAL(mem_dtype))
15951 ty = TY_REAL;
15952 else if (DT_ISCMPLX(mem_dtype))
15953 ty = TY_CMPLX;
15954 else
15955 ty = DTY(mem_dtype);
15956 /* Evaluate the kind expression. If we're processing the
15957 * default dtype, then ast is -1.
15958 */
15959 ast = chk_kind_parm_set_expr(KINDASTG(mem), dtype);
15960 if (ast > 0 && A_TYPEG(ast) == A_CNST) {
15961 value = CONVAL2G(A_SPTRG(ast));
15962 } else if (ast > 0) {
15963 error(155, ERR_Severe, gbl.lineno,
15964 "Kind type parameter value must be a compile-time constant"
15965 " for component",
15966 SYMNAME(mem));
15967 }
15968 if (ast > 0 || value == 1 || value == 2 || value == 4 || value == 8) {
15969 out_dtype = select_kind(mem_dtype, ty, value);
15970 } else {
15971 out_dtype = mem_dtype;
15972 }
15973 ty = DTY(out_dtype);
15974 if (ty == TY_CHAR || ty == TY_NCHAR)
15975 {
15976 int sym;
15977
15978 out_dtype = get_type(2, ty, DTY(mem_dtype + 1));
15979
15980 ast = DTY(mem_dtype + 1);
15981 switch (A_TYPEG(ast)) {
15982 case A_ID:
15983 case A_LABEL:
15984 case A_ENTRY:
15985 case A_SUBSCR:
15986 case A_SUBSTR:
15987 case A_MEM:
15988 sym = sym_of_ast(ast);
15989 break;
15990 default:
15991 sym = 0;
15992 }
15993 if (!get_len_parm(sym, dtype) && LENG(mem) && USELENG(mem)) {
15996 }
15997 } else {
15998 ast = 0;
15999 }
16000 if (ast)
16001 DTY(mem_dtype + 1) = ast;
16002 DTYPEP(mem, out_dtype);
16003 } else {
16004 int ast;
16005 DTYPE out_dtype;
16006 DTYPE base_dtype = DTY(mem_dtype + 1);
16007 int ty;
16008 if (DT_ISINT(base_dtype))
16009 ty = TY_INT;
16010 else if (DT_ISREAL(base_dtype))
16011 ty = TY_REAL;
16012 else if (DT_ISCMPLX(base_dtype))
16013 ty = TY_CMPLX;
16014 else
16015 ty = DTY(base_dtype);
16016 out_dtype = select_kind(base_dtype, ty, value);
16017 if (ty == TY_CHAR || ty == TY_NCHAR)
16018 {
16019 out_dtype = get_type(2, ty, DTY(base_dtype + 1));
16020 ast = DTY(base_dtype + 1);
16021 } else {
16022 ast = 0;
16023 }
16024
16025 DTY(mem_dtype + 1) = out_dtype;
16026
16027 if (ast)
16028 DTY(base_dtype + 1) = ast;
16029 }
16030 found = TRUE;
16031 } else if (flag <= 0 && !SETKINDG(mem) && !USEKINDG(mem) &&
16032 KINDG(mem) == offset) {
16033 if (flag == -1)
16034 DEFERLENP(mem, TRUE);
16035 if (flag == -2) {
16036 ASZP(mem, TRUE);
16037 }
16038 KINDP(mem, value);
16039 SETKINDP(mem, TRUE);
16040 if (LENPARMG(mem)) {
16041 LENP(mem, expr);
16042 }
16043 if (flag == 0 && !LENPARMG(mem) && expr &&
16044 !chk_kind_parm_expr(expr, dtype, 0, 1)) {
16045 error(155, 3, gbl.lineno, "Constant expression required for KIND type"
16046 " parameter",
16047 SYMNAME(mem));
16048 }
16049 found = TRUE;
16050 }
16051 }
16052 return found;
16053}
16054
16055static void
16057{
16058 int mem;
16059
16060 if (DTY(dtype) != TY_DERIVED)
16061 return;
16062
16063 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16064 if (DEFERLENG(mem)) {
16065 if (!LENPARMG(mem)) {
16066 error(155, 3, gbl.lineno,
16067 "Deferred type parameter (:) cannot be used with non-length type "
16068 "parameter",
16069 SYMNAME(mem));
16070 }
16071 if (!ALLOCATTRG(sptr) && !POINTERG(sptr)) {
16072 error(155, 3, gbl.lineno,
16073 "A deferred type parameter (:) must be used with "
16074 " an allocatable or pointer object",
16075 SYMNAME(sptr));
16076 }
16077 }
16078 if (ASZG(mem)) {
16079 if (!LENPARMG(mem)) {
16080 error(155, 3, gbl.lineno,
16081 "Assumed type parameter (*) cannot be used with non-length type "
16082 "parameter",
16083 SYMNAME(mem));
16084 }
16085 if (SCG(sptr) != SC_DUMMY) {
16086 error(155, 3, gbl.lineno,
16087 "An assumed type parameter (*) cannot be used with non-dummy "
16088 "argument",
16089 SYMNAME(sptr));
16090 }
16091 }
16092 }
16093}
16094
16095static int
16096get_vtoff(int vtoff, DTYPE dtype)
16097{
16099
16100 for (; sym > NOSYM; sym = SYMLKG(sym)) {
16101 if (PARENTG(sym)) {
16102 int parent_vtoff = VTOFFG(get_struct_tag_sptr(DTYPEG(sym)));
16103 if (parent_vtoff > vtoff) {
16104 vtoff = parent_vtoff;
16105 }
16106 vtoff = get_vtoff(vtoff, DTYPEG(sym));
16107 }
16108 if (is_tbp(sym)) {
16109 if (VTOFFG(BINDG(sym)) > vtoff) {
16110 vtoff = VTOFFG(BINDG(sym));
16111 }
16112 }
16113 }
16114 return vtoff;
16115}
16116
16117int
16118get_unl_poly_sym(int mem_dtype)
16119{
16120 int mem, dtype;
16121 int sptr = getsymf("_f03_unl_poly$%d", mem_dtype);
16122
16123 if (STYPEG(sptr) == ST_UNKNOWN) {
16124 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
16125 CCSYMP(sptr, 1);
16126 dtype = get_type(6, TY_DERIVED, NOSYM);
16127 DTYPEP(sptr, dtype);
16128 DTY(dtype + 1) = NOSYM;
16129 DTY(dtype + 2) = 0; /* will be filled in */
16130 DTY(dtype + 3) = sptr;
16131 DTY(dtype + 5) = 0;
16132 UNLPOLYP(sptr, 1);
16133 DCLDP(sptr, TRUE);
16134 if (!sem.interface)
16136 if (mem_dtype) {
16137 mem = getccsym_sc('d', sem.dtemps++, ST_MEMBER, SC_NONE);
16138 DTYPEP(mem, mem_dtype);
16139 SYMLKP(mem, DTY(dtype + 1));
16140 DTY(dtype + 1) = mem;
16141 }
16142 } else {
16143 dtype = DTYPEG(sptr);
16144 if (DTY(dtype) == TY_DERIVED) {
16145 DTY(dtype + 3) = sptr;
16146 UNLPOLYP(sptr, 1);
16147 CCSYMP(sptr, 1);
16149 }
16150 }
16151 return sptr;
16152}
16153
16154/** \brief Returns true if dtype is a derived type that has a type parameter or
16155 * if it has a component that has a type parameter.
16156 *
16157 * This function also takes into account recursive components.
16158 */
16159static int
16160has_type_parameter2(int dtype, int visit_flag)
16161{
16162 typedef struct visitDty {
16163 int dty;
16164 struct visitDty *next;
16165 } VISITDTY;
16166
16167 static VISITDTY *visit_list = 0;
16168 VISITDTY *curr, *new_visit, *prev;
16169
16170 int rslt;
16171 int dty = dtype;
16172 int member;
16173
16174 if (DTY(dty) == TY_ARRAY)
16175 dty = DTY(dty + 1);
16176
16177 if (DTY(dty) != TY_DERIVED) {
16178 return 0;
16179 }
16180
16181 if (visit_list) {
16182 for (curr = visit_list; curr; curr = curr->next) {
16183 if (curr->dty == dty) {
16184 return 0;
16185 }
16186 }
16187 }
16188
16189 NEW(new_visit, VISITDTY, 1);
16190 new_visit->dty = dty;
16191 new_visit->next = visit_list;
16192 visit_list = new_visit;
16193
16194 for (rslt = 0, member = DTY(dty + 1); member > NOSYM;
16195 member = SYMLKG(member)) {
16196 if (!USEKINDG(member) && KINDG(member)) {
16197 rslt = 1;
16198 break;
16199 }
16200 if (has_type_parameter2(DTYPEG(member), 1)) {
16201 rslt = 1;
16202 break;
16203 }
16204 }
16205
16206 if (!visit_flag && visit_list) {
16207 for (prev = curr = visit_list; curr;) {
16208
16209 curr = curr->next;
16210 FREE(prev);
16211 prev = curr;
16212 }
16213 visit_list = 0;
16214 }
16215
16216 return rslt;
16217}
16218
16219/** \brief checks to see if derived type record, dtype, has any type
16220 * parameters (kind or length type parameters).
16221 *
16222 * \param dtype is the derived type record we're searching
16223 *
16224 * \return integer > 0 if dtype has type parameters; else 0.
16225 */
16226int
16228{
16229 return has_type_parameter2(dtype, 0);
16230}
16231
16232#ifdef FLANG_SEMANT_UNUSED
16233static int
16234has_length_type_parameter(int dtype)
16235{
16236
16237 int mem;
16238
16239 if (DTY(dtype) != TY_DERIVED)
16240 return 0;
16241 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16242 if (PARENTG(mem) && has_length_type_parameter(DTYPEG(mem)))
16243 return 1;
16244 if (!USEKINDG(mem) && KINDG(mem) && LENPARMG(mem)) {
16245 return 1;
16246 }
16247 }
16248
16249 return 0;
16250}
16251#endif
16252
16253int
16255{
16256 int mem;
16257
16258 if (DTY(dtype) == TY_ARRAY)
16259 dtype = DTY(dtype + 1);
16260
16261 if (DTY(dtype) != TY_DERIVED)
16262 return 0;
16263 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16264 if (PARENTG(mem) && has_length_type_parameter_use(DTYPEG(mem)))
16265 return 1;
16266 if (USELENG(mem)) {
16267 return 1;
16268 }
16269 }
16270 return 0;
16271}
16272
16273static int
16275{
16276
16277 int mem, start, p;
16278
16279 if (DTY(dtype) != TY_DERIVED)
16280 return -1;
16281
16282 for (start = 0, mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16283 if (PARENTG(mem)) {
16284 start = get_highest_param_offset(DTYPEG(PARENTG(mem)));
16285 }
16286 if (!USEKINDG(mem) && (p = KINDG(mem))) {
16287 if (p > start)
16288 start = p;
16289 }
16290 }
16291
16292 return start;
16293}
16294
16295/** \brief Create a parameterized derived type based on dtype.
16296 If force is not set and dtype is already a PDT, return DT_NONE. */
16297DTYPE
16299{
16300 int mem;
16301 int prev_mem;
16302
16303 if (!has_type_parameter(dtype)) {
16304 return DT_NONE;
16305 }
16306 if (!force && is_pdt_dtype(dtype)) {
16307 return DT_NONE;
16308 }
16310 prev_mem = NOSYM;
16311 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16312 if (PARENTG(mem)) {
16313 DTYPE new_dtype = create_parameterized_dt(DTYPEG(mem), force);
16314 if (new_dtype) {
16315 int new_mem = insert_dup_sym(mem);
16316 DTYPEP(new_mem, new_dtype);
16317 if (prev_mem == NOSYM) {
16318 DTY(dtype + 1) = new_mem;
16319 } else {
16320 SYMLKP(prev_mem, new_mem);
16321 }
16322 }
16323 break;
16324 }
16325 prev_mem = mem;
16326 }
16327
16328 return dtype;
16329}
16330
16331/** \brief Duplicate \a dtype by creating a new derived type with a $pt suffix.
16332 For use with processing parameterized derived type.
16333 */
16334DTYPE
16336{
16337 int tag, mem, sptr;
16338 int first_mem = NOSYM;
16339 int curr_mem = NOSYM;
16340 DTYPE new_dtype;
16341 ACL *ict;
16342
16343 assert(DTY(dtype) == TY_DERIVED, "expected TY_DERIVED", DTY(dtype),
16344 ERR_Fatal);
16345
16346 tag = DTY(dtype + 3);
16347 sptr = get_next_sym(SYMNAME(tag), "pt");
16348 DINITP(sptr, DINITG(tag));
16349
16350 sptr = declsym(sptr, ST_TYPEDEF, TRUE);
16351 BASETYPEP(sptr, dtype);
16352 CCSYMP(sptr, 1);
16353 new_dtype = get_type(6, TY_DERIVED, NOSYM);
16354 DTYPEP(sptr, new_dtype);
16355 DTY(new_dtype + 2) = 0; /* will be filled in */
16356 DTY(new_dtype + 3) = sptr;
16357
16358 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
16359 int new_mem = insert_dup_sym(mem);
16360 VARIANTP(new_mem, curr_mem);
16361 ENCLDTYPEP(new_mem, new_dtype);
16362 ADDRESSP(new_mem, 0);
16363 if (first_mem == NOSYM) {
16364 first_mem = new_mem;
16365 } else {
16366 SYMLKP(curr_mem, new_mem);
16367 }
16368 curr_mem = new_mem;
16369 }
16370 DTY(new_dtype + 1) = first_mem;
16371 for (mem = first_mem; mem > NOSYM; mem = SYMLKG(mem)) {
16372 int descr;
16373 if (MIDNUMG(mem) && STYPEG(MIDNUMG(mem)) == ST_MEMBER) {
16374 int mid_mem = SYMLKG(mem);
16375 if (PTRVG(mid_mem) &&
16376 strcmp(SYMNAME(mid_mem), SYMNAME(MIDNUMG(mem))) == 0) {
16377 int off_mem;
16378 MIDNUMP(mem, mid_mem);
16379 off_mem = SYMLKG(mid_mem);
16380 if (PTROFFG(mem) && STYPEG(PTROFFG(mem)) == ST_MEMBER)
16381 PTROFFP(mem, off_mem);
16382 }
16383 }
16384
16385 if (SDSCG(mem) && STYPEG(mem) == ST_MEMBER) {
16386 /* Always dup the component descriptor's array dtype */
16387 int sdsc_mem = get_member_descriptor(mem);
16388 if (sdsc_mem > NOSYM && DESCARRAYG(sdsc_mem)) {
16389 DTYPEP(sdsc_mem, dup_array_dtype(DTYPEG(sdsc_mem)));
16390 SDSCP(mem, sdsc_mem);
16391 }
16392 }
16393 descr = DESCRG(mem);
16394 if (descr != 0) {
16395 /* duplicate the descr */
16396 int new_descr = insert_dup_sym(descr);
16397 DESCRP(mem, new_descr);
16398 SECDSCP(new_descr, match_memname(SECDSCG(new_descr), first_mem));
16399 ARRAYP(new_descr, match_memname(ARRAYG(new_descr), first_mem));
16400 }
16401 }
16402
16403 ict = get_getitem_p(DTY(dtype + 5));
16404 if (ict != 0) {
16405 ACL *newict = dup_acl(ict, sptr);
16406 DTY(new_dtype + 5) = put_getitem_p(newict);
16407 } else {
16408 DTY(new_dtype + 5) = 0;
16409 }
16410
16412 return new_dtype;
16413}
16414
16415static ACL *
16417{
16418 ACL *subc = src->subc;
16419 ACL *next = src->next;
16420 ACL *dst = GET_ACL(15);
16421 *dst = *src;
16422 dst->sptr = sptr;
16423 if (DTY(src->dtype) == TY_DERIVED) {
16424 dst->dtype = DTYPEG(sptr);
16425 }
16426 if (subc != 0) {
16427 dst->subc = dup_acl(subc, match_memname(subc->sptr, DTY(DTYPEG(sptr) + 1)));
16428 }
16429 if (next != 0) {
16430 dst->next = dup_acl(next, match_memname(next->sptr, SYMLKG(sptr)));
16431 }
16432 return dst;
16433}
16434
16435/* Return the symbol in mem list (linked through SYMLK) whose name matches sptr.
16436 Return sptr if there is none. */
16437static int
16439{
16440 for (; mem > NOSYM; mem = SYMLKG(mem)) {
16441 if (NMPTRG(sptr) == NMPTRG(mem)) {
16442 return mem;
16443 }
16444 }
16445 return sptr;
16446}
16447
16448/* Return TRUE if dtype represents a parameterized derived type. */
16449static LOGICAL
16451{
16452 return DTY(dtype) == TY_DERIVED &&
16453 strstr(SYMNAME(DTY(dtype + 3)), "$pt") != 0;
16454}
16455
16456/** \brief allow other source files to check whether we're processing a
16457 * parameter construct.
16458 */
16459int
16461{
16462 return (entity_attr.exist & ET_B(ET_PARAMETER));
16463}
16464
16465static LOGICAL
16467{
16468 if (sem.which_pass == 0) {
16469 if (sem.mod_cnt && gbl.currsub) {
16470 /*
16471 * Do not process the common declaration if in a module subroutine
16472 */
16473 return TRUE;
16474 }
16475 }
16476 return FALSE;
16477}
16478
16479/** \brief Return the predicate: current entity has the INTRINSIC attribute. */
16480bool
16482{
16483 return (entity_attr.exist & ET_B(ET_INTRINSIC)) != 0;
16484}
16485
16486/** \brief provide the current entity's access to other source files. */
16487int
16489{
16490 return entity_attr.access;
16491}
16492
16493/** \brief provide mscall variable state to other source files. */
16494int
16496{
16497 return mscall;
16498}
16499
16500/** \brief provide cref variable state to other source files. */
16501int
16503{
16504 return cref;
16505}
16506
16507/** \brief Determine procedure symbol type for a set of attributes
16508 *
16509 * \param attr attribute mask
16510 *
16511 * \return symbol type index, zero on error
16512 */
16513static int
16515{
16516 if (attr & ET_B(ET_POINTER)) {
16517 if (!INSIDE_STRUCT) {
16518 return ST_VAR;
16519 }
16520
16521 return ST_MEMBER;
16522 }
16523
16524 if (INSIDE_STRUCT) {
16525 return 0;
16526 }
16527
16528 return ST_PROC;
16529}
16530
16531/** \brief Declare a procedure symbol
16532 *
16533 * Perform check nesessary for a declaration or procedure and produce a new
16534 * symbol that matches procedure interface and attributes
16535 *
16536 * \param sptr symbol table index for the symbol
16537 * \param proc_interf_sptr symbol table entry for procedure interface
16538 * \param attr attributes (bit vector), same as entity_attr.exist
16539 *
16540 * \return symbol table index for created symbol
16541 */
16542static int
16543decl_procedure_sym(int sptr, int proc_interf_sptr, int attr)
16544{
16545 /* First get expected symbol type */
16546 int stype = get_procedure_stype(attr);
16547
16548 if (!stype) {
16549 /* TODO better place for this error message? */
16550 error(155, 3, gbl.lineno,
16551 "PROCEDURE component must have the POINTER attribute -",
16552 SYMNAME(sptr));
16553 return 0;
16554 }
16555
16556 /* Create a new symbol */
16557 if (stype != ST_MEMBER) {
16558 sptr = declsym(sptr, stype, FALSE);
16559 } else {
16560 if (STYPEG(sptr) != ST_UNKNOWN)
16561 sptr = insert_sym(sptr);
16562 SYMLKP(sptr, NOSYM);
16563 STYPEP(sptr, ST_MEMBER);
16564 if (attr & ET_B(ET_NOPASS)) {
16565 NOPASSP(sptr, 1);
16566 } else {
16567 if (!proc_interf_sptr) {
16568 error(155, 3, gbl.lineno, "The NOPASS attribute must be present for",
16569 SYMNAME(sptr));
16570 }
16571 if (attr & ET_B(ET_PASS)) {
16572 PASSP(sptr, entity_attr.pass_arg);
16573 if (IN_MODULE_SPEC) {
16574 /* Pop the pass arg so it does not pollute
16575 * other dummy arguments with same name in module.
16576 * That's because we do not rewrite the pass arg when
16577 * it's encountered in the contains subroutine. We only
16578 * write out new symbols. The pass arg does not get its
16579 * STYPE and CLASS fields, for example, set until we
16580 * process the contains subroutine. Later, when we use
16581 * the module, we pull in the uninitialized pass argument
16582 * which leads to problems if arg is declared CLASS and
16583 * it does not have CLASS set.
16584 */
16585 pop_sym(entity_attr.pass_arg);
16586 }
16587 }
16588 }
16589 }
16590
16591 return sptr;
16592}
16593
16594/** \brief Process procedure declaration
16595 *
16596 * Modify symbol table entry for a procedure declaration, producing the right
16597 * datatype for procedure pointers or members.
16598 *
16599 * \param sptr symbol table index for the symbol
16600 * \param proc_interf_sptr symbol table entry for procedure interface
16601 * \param attr attributes (bit vector), same as entity_attr.exist
16602 * \param access access level, same as entity_attr.access
16603 *
16604 * \return index of produced symbol table entry, 0 if error
16605 *
16606 */
16607static int
16608setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access)
16609{
16610 int stype;
16611 int dtype;
16612
16613 /* ********** Determine symbol type ********** */
16614 stype = get_procedure_stype(attr);
16615
16616 /*
16617 * Check for required attributes
16618 */
16619 if (!stype) {
16620 /* TODO better place for this error message? */
16621 error(155, 3, gbl.lineno,
16622 "PROCEDURE component must have the POINTER attribute -",
16623 SYMNAME(sptr));
16624 return 0;
16625 }
16626
16627 if ((stype != ST_MEMBER) && (attr & (ET_B(ET_SAVE) | ET_B(ET_INTENT)))) {
16628 if (!(attr & ET_B(ET_POINTER))) {
16629 error(155, 3, gbl.lineno, "The POINTER attribute must be present for",
16630 SYMNAME(sptr));
16631 return sptr;
16632 }
16633 }
16634
16635 STYPEP(sptr, stype);
16636
16637 if (sem.gdtype != -1) {
16638 dtype = sem.gdtype;
16639 } else if (proc_interf_sptr) {
16640 dtype = DTYPEG(proc_interf_sptr);
16641 } else {
16642 dtype = DTYPEG(sptr);
16643 }
16644 DCLDP(sptr, TRUE);
16645 if (stype == ST_PROC) {
16646 if (proc_interf_sptr && (!gbl.currsub || SCG(sptr))) {
16647 defer_iface(proc_interf_sptr, 0, sptr, 0);
16648 } else if (scn.stmtyp == TK_PROCEDURE)
16649 /* have a procedure without an interface, i.e.,
16650 * procedure() [...] :: foo
16651 * Assume 'subroutine'
16652 */
16653 dtype = DT_NONE;
16654 } else {
16655 /* stype == ST_MEMBER or ST_VAR => have an entity-style declaration with
16656 * the POINTER attribute
16657 */
16658 dtype = get_type(6, TY_PROC, dtype);
16659 DTY(dtype + 2) = 0; /* interface */
16660 DTY(dtype + 3) = 0; /* PARAMCT */
16661 DTY(dtype + 4) = 0; /* DPDSC */
16662 DTY(dtype + 5) = 0; /* FVAL */
16663
16664 if (proc_interf_sptr) {
16665 DTY(dtype + 2) = proc_interf_sptr; /* Set interface */
16666 defer_iface(proc_interf_sptr, dtype, 0, sptr);
16667 } else if (sem.gdtype == -1)
16668 /*
16669 * Have procedure( ), pointer [...] :: foo k
16670 * If a type appears as the interface name, sem.gdtype will be set to
16671 * that type.
16672 */
16673 DTY(dtype + 1) = DT_NONE;
16674
16675 dtype = get_type(2, TY_PTR, dtype);
16676 if (STYPEG(sptr) != ST_VAR || !IS_PROC_DUMMYG(sptr))
16677 POINTERP(sptr, TRUE);
16678
16679 if (access == 'v' || (sem.accl.type == 'v' && access != 'u')) {
16680 /* Set PRIVATE here for procedure pointers. */
16681 PRIVATEP(sptr, 1);
16682 }
16683 }
16684 DTYPEP(sptr, dtype);
16685
16686 /* ********** Add any additional attributes and return ********** */
16687 if (stype == ST_MEMBER) {
16688 stsk = &STSK_ENT(0);
16689 /* link field-namelist into member list at this level */
16691 }
16692
16693 if (attr & ET_B(ET_SAVE))
16694 SAVEP(sptr, 1);
16695 if (attr & ET_B(ET_OPTIONAL))
16696 OPTARGP(sptr, 1);
16697 if (attr & ET_B(ET_PROTECTED))
16698 PROTECTEDP(sptr, 1);
16699 if (attr & ET_B(ET_BIND))
16701
16702 return sptr;
16703}
16704
16705static void
16706record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY)
16707{
16708 if (gbl.rutype != RU_FUNC)
16709 return; /* can't have a RESULT clause unless a function */
16710 if (in_ENTRY && FVALG(func_sptr) != 0) {
16711 if (func_result_sptr)
16712 error(155, 3, gbl.lineno, "The ENTRY cannot have a result name -",
16713 SYMNAME(func_sptr));
16714 return;
16715 }
16716 if (func_result_sptr != 0) {
16717 /* result variable from RESULT(func_result_sptr) clause */
16718 RESULTP(func_sptr, TRUE);
16719 if (in_ENTRY)
16720 DCLDP(func_sptr, TRUE);
16721 } else {
16722 /* insert a dummy variable with the name of the function */
16723 func_result_sptr = insert_sym(func_sptr);
16724 pop_sym(func_result_sptr);
16725 STYPEP(func_result_sptr, ST_IDENT);
16726 SCOPEP(func_result_sptr, stb.curr_scope);
16727 SCP(func_result_sptr, SC_DUMMY);
16728 if (!in_ENTRY && sem.interface) {
16729 NODESCP(func_result_sptr, TRUE);
16730 IGNOREP(func_result_sptr, TRUE);
16731 }
16732 }
16733 if (in_ENTRY && RESULTG(func_result_sptr) != 0) {
16734 /* create_func_entry_result() discovered that a variable
16735 * named the same as the result-name was already declared.
16736 * transfer data type to entry
16737 */
16738 DTYPEP(func_sptr, DTYPEG(func_result_sptr));
16739 } else {
16740 if (DTYPEG(func_sptr)) {
16741 /* transfer data type from FUNCTION statement to func_result_sptr */
16742 DTYPEP(func_result_sptr, DTYPEG(func_sptr));
16743 ADJLENP(func_result_sptr, ADJLENG(func_sptr));
16744 }
16745 RESULTP(func_result_sptr, TRUE);
16746 }
16747 FVALP(func_sptr, func_result_sptr);
16748 if (DCLDG(func_sptr))
16749 DCLDP(func_result_sptr, TRUE);
16750}
16751
16752/** \brief Determine if a type bound procedure (tbp) binding name requires
16753 * overloading.
16754 *
16755 * This is called by the <binding name> ::= <id> '=>' <id> production
16756 * above. After the tbp is set up, we perform additional overloading checks
16757 * in resolveBind() of semtbp.c.
16758 *
16759 * \pararm sptr is the binding name that we are checking.
16760 *
16761 * \return true if it is an overloaded binding name, else false.
16762 */
16763static bool
16765{
16766 if (STYPEG(sptr) == ST_PD) {
16767 /* Overloaded intrinsic with same name. */
16768 return true;
16769 }
16770
16771 if (STYPEG(sptr) == ST_PROC) {
16772
16773 if (SCOPEG(sptr) != stb.curr_scope) {
16774 /* Another use associated symbol with same name. */
16775 return true;
16776 }
16777
16778 if (IN_MODULE_SPEC && TBPLNKG(sptr) == 0) {
16779 /* Another symbol in module specification section with same name and
16780 * same scope.
16781 * This is possibly a procedure with the same name declared in an
16782 * interface block.
16783 */
16784 return true;
16785 }
16786 }
16787 return false;
16788}
16789
16790const char *
16792{
16793 switch (sem.pgphase) {
16794 case PHASE_END_MODULE:
16795 return "END_MODULE";
16796 case PHASE_INIT:
16797 return "INIT";
16798 case PHASE_HEADER:
16799 return "HEADER";
16800 case PHASE_USE:
16801 return "USE";
16802 case PHASE_IMPORT:
16803 return "IMPORT";
16804 case PHASE_IMPLICIT:
16805 return "IMPLICIT";
16806 case PHASE_SPEC:
16807 return "SPEC";
16808 case PHASE_EXEC:
16809 return "EXEC";
16810 case PHASE_CONTAIN:
16811 return "CONTAIN";
16812 case PHASE_INTERNAL:
16813 return "INTERNAL";
16814 case PHASE_END:
16815 return "END";
16816 }
16817}
16818
16819/** \brief To re-initialize an array of derived types when found the
16820 * following conditions are satisfied:
16821 1. the element of the array is a derived type.
16822 2. the array has been initialized before and needs to be
16823 re-initialized.
16824 3. none of any entity attributes used for array definition.
16825 */
16826static bool
16828{
16829 return sem.dinit_count > 0 && inited && !entity_attr.exist &&
16830 STYPEG(sptr) == ST_IDENT && sst_idg == S_ACONST &&
16831 DTY(DTYPEG(sptr)) == TY_ARRAY && DTYG(DTYPEG(sptr)) == TY_DERIVED &&
16832 /* found the tag has been initialized already with a valid sptr*/
16833 DINITG(DTY(DTY(DTYPEG(sptr)+1)+3));
16834}
void(F90_Desc *sd, __NELEM_T *nelem, __INT_T *kind, __INT_T *len, __STAT_T *stat, char **pointer, __POINT_T *offset, __INT_T *firsttime, __NELEM_T *align, DCHAR(errmsg) DCLEN64(errmsg))
Definition: allo.c:1348
void sym_is_refd(int sptr)
Definition: assem.c:42
char * mem(char *r)
int ast
Definition: ast.c:4213
INT cngcon(INT oldval, int oldtyp, int newtyp)
Convert constant from oldtyp to newtyp.
Definition: ast.c:8769
int mk_bnd_int(int expr)
Utility function to ensure that an expression has a type suitable for array bounds,...
Definition: ast.c:7499
int mk_subscr(int arr, int *subs, int numdim, DTYPE dtype)
Definition: ast.c:1974
int add_stmt(int ast)
Definition: ast.c:3888
short next
Definition: ast.c:2390
INT negate_const(INT conval, DTYPE dtype)
Definition: ast.c:8011
void ast_to_comment(int ast)
Definition: ast.c:4077
void ast_visit(int old, int new)
Add an AST to the visit list.
Definition: ast.c:4370
int mk_comstr(char *str)
Definition: ast.c:4093
int argt
Definition: ast.c:4212
int mk_cval(INT v, DTYPE dtype)
Definition: ast.c:565
void mk_alias(int ast, int a_cnst)
Create an alias of ast if it isn't a constant AST. Its alias field will be set to the ast 'a_cnst'.
Definition: ast.c:676
int mk_cnst(int cnst)
Make a constant AST given a constant symbol table pointer.
Definition: ast.c:553
int mk_binop(int optype, int lop, int rop, DTYPE dtype)
Definition: ast.c:689
int mk_id(int id)
Definition: ast.c:512
int mk_unop(int optype, int lop, DTYPE dtype)
...
Definition: ast.c:1234
static int visit_list
Definition: ast.c:4355
void ast_traverse(int ast, ast_preorder_fn preorder, ast_visit_fn postorder, int *extra_arg)
General ast traversal function: uses a list to keep track of the ast nodes which have been visited; i...
Definition: ast.c:5565
int mk_member(int parent, int mem, DTYPE dtype)
Definition: ast.c:2220
int complex_alias(int ast)
For an AST tree with members and subscripts, if the base variable has the PARAMG bit set and all the ...
Definition: ast.c:2139
int replace_memsym_of_ast(int ast, SPTR sptr)
Generate a replacement AST with a new sptr for certain AST types.
Definition: ast.c:3087
void ast_implicit(int firstc, int lastc, DTYPE dtype)
Definition: ast.c:4195
int mk_cval1(INT v, DTYPE dtype)
Make a constant AST given the actual (single word) value or a constant symbol table pointer; determin...
Definition: ast.c:615
int mk_subscr_copy(int arr, int asd, DTYPE dtype)
Definition: ast.c:1981
int mk_shared_extent(int lb, int ub, int dim)
Definition: ast.c:2882
int mk_convert(int lop, DTYPE dtype)
Definition: ast.c:1350
void ast_init(void)
Initialize AST table for new user program unit.
Definition: ast.c:60
short ndim
Definition: ast.c:2389
int sym_of_ast(int ast)
Like memsym_of_ast(), but for a member, returns the sptr of its parent, not the member.
Definition: ast.c:2931
int mk_stmt(int stmt_type, DTYPE dtype)
Definition: ast.c:3864
int mk_isz_cval(ISZ_T v, DTYPE dtype)
Definition: ast.c:594
void ast_unvisit(void)
Traverse the visit list to clean up the nodes in the list.
Definition: ast.c:4416
INT const_fold(int opr, INT conval1, INT conval2, DTYPE dtype)
Definition: ast.c:8095
#define OP_ADD
Definition: ast.in.h:44
#define A_OPTYPEP(s, v)
Definition: ast.in.h:23
#define A_ARGCNTG(s)
Definition: ast.in.h:32
#define STD_PREV(i)
Definition: ast.in.h:203
#define OP_LEQV
Definition: ast.in.h:58
#define OP_MUL
Definition: ast.in.h:46
#define A_OPTYPEG(s)
Definition: ast.in.h:22
#define OP_LNEQV
Definition: ast.in.h:59
ASTB astb
#define ARGT_ARG(i, j)
Definition: ast.in.h:117
#define STD_LABEL(i)
Definition: ast.in.h:204
#define OP_SUB
Definition: ast.in.h:45
#define OP_LNOT
Definition: ast.in.h:68
#define OP_CAT
Definition: ast.in.h:56
#define OP_LOR
Definition: ast.in.h:60
#define A_ISEXPR(a)
Definition: ast.in.h:84
#define OP_XTOI
Definition: ast.in.h:48
#define OP_LAND
Definition: ast.in.h:61
#define STD_AST(i)
Definition: ast.in.h:201
#define OP_ST
Definition: ast.in.h:53
void add_param(int sptr)
Add parameters in the order in which they were declared.
Definition: astout.c:4413
void end_param(void)
Since a separate list is created for each parameter combination of ansi-/vax- style and constant/non-...
Definition: astout.c:4446
@ AOP_UNDEF
Definition: atomic_common.h:92
@ MO_UNDEF
Definition: atomic_common.h:58
void bblock_init()
Called from semant_init().
Definition: bblock.c:54
static char * buf
Definition: buffer.c:27
void setfile(int f, const char *funcname, int tag)
...
Definition: ccffinfo.c:2724
function prototypes and macros for ccffinfo. Function prototypes and macros for common compiler feedb...
static uint2 uint32_t uint32_t c
Definition: cexpf/common.h:62
uint32_t e
Definition: cis_common.h:23
int32_t idx
Definition: cis_common.h:24
double d
Definition: cis_common.h:69
uint64_t p
Definition: cis_common.h:50
int list
Definition: commopt.c:654
int src
Definition: commopt.c:652
#define TY_CMPLX
Definition: dattype.h:22
#define TY_NCHAR
Definition: dattype.h:28
#define TY_DBLE
Definition: dattype.h:20
#define TY_QUAD
Definition: dattype.h:21
#define TY_REAL
Definition: dattype.h:19
#define TY_LOG8
Definition: dattype.h:30
#define TY_DCMPLX
Definition: dattype.h:23
#define TY_CHAR
Definition: dattype.h:27
#define TY_BINT
Definition: dattype.h:16
#define TY_INT
Definition: dattype.h:18
#define TY_LOG
Definition: dattype.h:26
LOGICAL dinit_ok(int sptr)
...
Definition: dinit.c:1602
void dinit_no_dinitp(VAR *ivl, ACL *ict)
Definition: dinit.c:163
void df_dinit(VAR *ivl, ACL *ict)
Definition: dinit.c:184
void dinit(VAR *ivl, ACL *ict)
Definition: dinit.c:60
static DOSTACK * top
Definition: dinit.cpp:72
void direct_loop_end(int beg_line, int end_line)
Re-initialize the loop structure.
Definition: direct.c:227
int chk_kind_parm_set_expr(int ast, DTYPE dtype)
Definition: dtypeutl.c:3721
LOGICAL is_procedure_dtype(DTYPE dtype)
Test if a data type index corresponds with a procedure.
Definition: dtypeutl.c:4182
LOGICAL is_array_dtype(DTYPE dtype)
...
Definition: dtypeutl.c:4102
int get_struct_initialization_tree(DTYPE dtype)
Definition: dtypeutl.c:4244
void chkstruct(DTYPE dtype)
Compute size and alignment of struct and union types and their members.
Definition: dtypeutl.c:3842
LOGICAL is_empty_typedef(DTYPE dtype)
Check for special case of empty typedef which has a size of 0 but one member of type DT_NONE to indic...
Definition: dtypeutl.c:401
void set_proc_ptr_param_count_dtype(DTYPE ptr_dtype, int param_count)
Set paramter count for a procedure pointer type.
Definition: dtypeutl.c:4170
void set_proc_result_dtype(DTYPE proc_dtype, DTYPE result_dtype)
Set return type for a procedure type.
Definition: dtypeutl.c:4192
void set_proc_ptr_result_dtype(DTYPE ptr_dtype, DTYPE result_dtype)
Set return type for a procedure pointer.
Definition: dtypeutl.c:4157
LOGICAL eq_dtype2(DTYPE d1, DTYPE d2, LOGICAL flag)
In the presence of modules and interface blocks, it's possible that two identical derived types are n...
Definition: dtypeutl.c:1656
LOGICAL has_tbp_or_final(DTYPE dtype)
Definition: dtypeutl.c:3715
DTYPE get_type(int n, TY_KIND v1, int v2)
...
Definition: dtypeutl.c:1385
LOGICAL is_procedure_ptr_dtype(DTYPE dtype)
Test if a data type index corresponds with a procedure pointer.
Definition: dtypeutl.c:4137
ISZ_T ad_val_of(int sym)
...
Definition: dtypeutl.c:1182
int string_length(DTYPE dtype)
Return length of constant char string data type.
Definition: dtypeutl.c:229
LOGICAL has_finalized_component(SPTR sptr)
Definition: dtypeutl.c:1821
DTYPE array_element_dtype(DTYPE dtype)
if array datatype, returns the element dtype, else returns dtype
Definition: dtypeutl.c:4108
SPTR get_struct_tag_sptr(DTYPE dtype)
Definition: dtypeutl.c:4232
DTYPE dup_array_dtype(DTYPE o_dt)
Duplicate a dtype array record and its array descriptor.
Definition: dtypeutl.c:3186
ISZ_T size_of(DTYPE dtype)
...
Definition: dtypeutl.c:96
SPTR get_struct_members(DTYPE dtype)
Definition: dtypeutl.c:4238
int zbase
Definition: exp_ftn.cpp:1553
int scope
void __INT_T __INT_T __STAT_T char __POINT_T * offset
Definition: f90alloc.h:16
directive/pragma data structures.
SWEL * switch_base
Definition: fenddf.c:31
SCN scn
Definition: fenddf.c:27
SEM sem
Definition: fenddf.c:23
AUX aux
Definition: fenddf.c:33
int prev
Definition: fgraph.c:1618
int * parent
Definition: fgraph.c:44
File Information Header (FIH)
struct proc proc
Definition: fioMacros.h:728
#define MAXDIMS
Definition: fioMacros.h:496
#define FREE(p)
#define BCOPY(p, q, dt, n)
void * get_getitem_p(int)
returns the pointer stored at index i.
Definition: salloc.c:158
void end_contained(void)
called at end of processing contains subprograms
Definition: main.c:1472
#define WINNT_CALL
int put_getitem_p(void *)
stores the pointer in the pointer table and returns its index.
Definition: salloc.c:134
char * getitem(int, int)
Definition: salloc.c:37
#define CNULL
#define uf(s)
#define XBIT(n, m)
#define WINNT_NOMIXEDSTRLEN
#define NEED(n, p, dt, size, newsize)
#define NEW(p, dt, n)
void freearea(int)
Definition: salloc.c:83
#define SCFTN_TRUE
#define BZERO(p, dt, n)
#define ISZ_T
#define SCFTN_FALSE
#define WINNT_CREF
void init_named_array_constant(int, int)
Initialize a named array constant (array PARAMETER), ensuring that it's only being done within the co...
Definition: semutil2.c:1533
int queue_tbp(int sptr, int bind, int offset, int dtype, tbpTask task)
Main function for processing type bound procedures (tbps), generic type bound procedures,...
Definition: semtbp.c:173
#define DI_DOINFO(d)
#define S_LVALUE
int get_static_type_descriptor(int sptr)
Return the "static type descriptor" for object sptr. The static type descriptor holds the "declared t...
Definition: semfunc.c:123
void link_members(STSK *, int)
Link together members of a structure.
Definition: semutil.c:1970
#define DI_EXIT_LABEL(d)
void mk_assumed_shape(SPTR)
Definition: semutil2.c:840
#define S_CONST
void check_no_scope_sptr(void)
Definition: semsmp.c:9627
DTYPE select_kind(DTYPE, int, INT)
Definition: semutil2.c:875
#define NEED_DOIF(df, typ)
#define IN_MODULE
int refsym_inscope(int, OVCLASS)
Similar to refsym() except that the current scope is taken into consideration.
Definition: semsym.c:1009
LOGICAL cuda_enabled(const char *)
If we are accepting cuda syntax return TRUE. Otherwise issue an error message and return FALSE.
Definition: semutil2.c:8465
void link_parents(STSK *, int)
Link parents for type extension by adding parent as a member to the type.
Definition: semutil.c:1913
#define DI_NEST(d)
void add_overload(int, int)
Definition: semgnr.c:1863
void gen_deallocate_arrays(void)
Generate deallocates for the temporary arrays in the sem.p_delloc list.
Definition: semutil2.c:752
int get_construct_name(void)
Definition: semant3.c:5688
#define EQV_NUMSS(i)
void mk_defer_shape(SPTR)
Definition: semutil2.c:803
void add_auto_finalize(int)
Definition: semutil2.c:12354
int declref(int, SYMTYPE, int)
Look up symbol having a specific symbol type.
Definition: semsym.c:491
int sym_in_scope(int, OVCLASS, int *, int *, int)
Look for a symbol with same name as first and in an active scope.
Definition: semsym.c:96
@ TBP_NONOVERRIDABLE
@ TBP_COMPLETE_ENDMODULE
@ TBP_COMPLETE_ENDTYPE
@ SCOPE_SUBPROGRAM
#define IS_INTRINSIC(st)
#define ATOMIC_CAPTURE
int get_intrinsic_opr(int, int)
Definition: semgnr.c:1076
int iface_intrinsic(int)
Definition: semfunc2.c:2708
ACL * mk_init_intrinsic(AC_INTRINSIC)
Definition: semutil2.c:3505
#define AC_AST
#define S_ACONST
int ref_ident_inscope(int)
Definition: semsym.c:1252
void end_teams()
Definition: semsmp.c:8741
void defer_arg_chk(SPTR formal, SPTR actual, SPTR subprog, cmp_interface_flags, int lineno, bool performChk)
Process information for deferred interface argument checking in in the compat_arg_lists() function be...
Definition: semfunc2.c:1991
#define DI_DO_LABEL(d)
#define DCLCHK(sptr)
void check_defined_io(void)
Definition: semgnr.c:1818
int mod_type(int, int, int, int, int, int)
Return a new data type based on the rules of applying a length specifier to an existing base data typ...
Definition: semutil.c:5568
#define S_EXPR
int get_nml_array(int)
Create the array (ST_PLIST) representing the namelist.
Definition: semantio.c:4990
void save_struct_init(ACL *)
Definition: semutil2.c:5597
void save_host_state(int)
Called from semant.c to save the semant, sym, dtype, ast, and other 'state' information from a host r...
Definition: semutil2.c:13635
int get_intrinsic_oprsym(int, int)
Definition: semgnr.c:1065
void restore_host_state(int)
Called at the end of an internal subprogram.
Definition: semutil2.c:13759
#define DI_ISSIMD(d)
#define S_TRIPLE
void xrefput(int symptr, int usage)
Write one reference record to Reference File:
Definition: xref.c:49
void dummy_program(void)
Check whether there is a subprogram statement; if not, create a dummy program symbol,...
Definition: semutil2.c:13548
#define S_KEYWORD
int declsym(int, SYMTYPE, LOGICAL)
Declare a new symbol.
Definition: semsym.c:644
#define Dostart
ACL * save_acl(ACL *)
Definition: semutil2.c:5145
void parstuff_init(void)
Definition: semsmp.c:5768
ACL * eval_init_expr(ACL *e)
Definition: semutil2.c:11835
#define DI_LINENO(d)
int newsym(int)
Reset fields of intrinsic or generic symbol, sptr, to zero in preparation for changing its symbol typ...
Definition: semsym.c:1183
SPTR get_param_alias_var(SPTR, DTYPE)
Definition: semutil2.c:1543
void check_generic(int)
Definition: semgnr.c:142
void semfin(void)
Finalize semantic processing.
Definition: semfin.c:319
#define Doend
#define DI_ENCL_BLOCK_SCOPE(d)
void fix_type_param_members(SPTR, DTYPE)
Definition: semutil2.c:13145
#define AC_VMSSTRUCT
@ DI_FIRST_DIRECTIVE
@ DI_ACCPARALLELDO
@ DI_TARGTEAMSDISTPARDO
@ DI_ACCKERNELSLOOP
@ DI_TEAMSDISTPARDO
@ DI_TARGTEAMSDIST
@ DI_ACCSERIALLOOP
@ DI_ACCPARALLELLOOP
void restore_internal_subprograms(void)
Called at the beginning of a subprogram in pass 2.
Definition: semutil2.c:13882
void fix_class_args(int sptr)
Add type descriptor arguments to a specified function if they have not already been added.
Definition: semfin.c:1065
#define DI_ID(d)
void enforce_denorm(void)
Definition: semsym.c:1100
#define INSIDE_STRUCT
#define AC_TYPEINIT
int mk_set_type_call(int arg0, int arg1, LOGICAL intrin_type)
Creates an ast that represents a call to a set type runtime routine.
Definition: semutil2.c:14716
#define _INF_CLEN
SPTR block_local_sym(SPTR)
Return a symbol local to the current BLOCK if applicable.
Definition: semsym.c:1538
#define DI_B(t)
void chk_struct_constructor(ACL *)
Definition: semutil2.c:6226
int have_module_state(void)
Definition: semutil2.c:14116
void copy_specifics(int fromsptr, int tosptr)
Definition: semgnr.c:1880
#define S_IDENT
#define EQV(i)
ACL * dinit_struct_vals(ACL *, DTYPE, SPTR)
In DATA statement, do the stuff in dinit_struct_const in two steps.
Definition: semutil2.c:7606
void chk_adjarr(void)
Definition: semutil2.c:88
ACL * construct_acl_from_ast(int, DTYPE, int)
Definition: semutil2.c:4540
void set_construct_name(int name)
Definition: semant3.c:5682
void do_end(DOINFO *)
Definition: semutil.c:6385
bool in_save_scope(SPTR)
Definition: semutil.c:2480
DTYPE mk_arrdsc(void)
Definition: semutil2.c:573
#define IN_MODULE_SPEC
void end_target()
Definition: semsmp.c:8758
#define ITEM_END
int emit_bcs_ecs(int)
Definition: semsmp.c:6304
int refsym(int, OVCLASS)
Look up a symbol having the given overloading class.
Definition: semsym.c:946
#define AC_VMSUNION
ISZ_T size_of_array(DTYPE)
Check if array has zero size.
Definition: semutil2.c:1399
int sem_strcmp(const char *, const char *)
Compare str and pattern like strcmp() but ignoring the case of str. pattern is all lower case.
Definition: semutil2.c:8186
#define S_NULL
void fixup_reqgs_ident(int sptr)
LOGICAL use_opt_atomic(int)
Decide to use optimized atomic usage.
Definition: semsmp.c:10308
#define S_STAR
#define DI_NAME(d)
void semfin_free_memory(void)
Deallocate data structures for semantic analysis.
Definition: semfin.c:1032
ACL * rewrite_acl(ACL *, DTYPE, int)
Definition: semutil2.c:4880
#define GET_ACL(a)
#define S_SCONST
#define AC_SCONST
int ref_ident(int)
Reference a symbol when it's known the context requires an identifier.
Definition: semsym.c:1235
void sem_err104(int, int, const char *)
Definition: semutil2.c:14590
int getocsym(int, OVCLASS, LOGICAL)
Look up symbol matching overloading class of given symbol type.
Definition: semsym.c:1127
#define STSK_ENT(i)
void err307(const char *, int, int)
Definition: semant3.c:6162
#define EQV_SS(i, j)
void sem_import_sym(int)
IMPORT symbol from host scope – not to be confused with interf import stuff.
Definition: semsym.c:325
LOGICAL ast_isparam(int ast)
Definition: semutil.c:2614
void clean_struct_default_init(int)
Definition: semutil2.c:5520
void add_type_param_initialize(int)
Definition: semutil2.c:12334
#define ATOMIC_UNDEF
int select_gsame(int)
Given a generic intrinsic, select the corresponding specific of the same name.
Definition: semfunc2.c:1386
int test_scope(int)
Definition: semsym.c:440
void init_intrinsic_opr(void)
Definition: semgnr.c:1024
STB stb
SPTR lookupsymbol(const char *name)
Get the symbol table index for a NUL-terminated name.
SPTR lookupsymf(const char *fmt,...)
Construct a name via printf-style formatting and then look it up in the symbol table via lookupsymbol...
#define HASH_STR(hv, p, len)
#define HASHSIZE
#define HASH_ID(hv, p, len)
#define DLLP(s, v)
#define DT_ISINT(dt)
#define DT_ISCMPLX(dt)
#define AD_UPAST(p, i)
#define AD_EXTNTAST(p, i)
#define DLL_IMPORT
#define AD_PTR(sptr)
#define AD_NUMDIM(p)
#define AD_DPTR(dtype)
#define DLL_EXPORT
#define AD_ASSUMSZ(p)
#define ADD_LWAST(dtyp, i)
#define INTENT_INOUT
#define AD_ZBASE(p)
#define AD_NOBOUNDS(p)
#define INTENT_OUT
#define CUDAG(s)
#define INTENT_DFLT
#define ADD_NUMDIM(dtyp)
#define DT_CMPLX
#define AD_NUMELM(p)
#define AD_UPBD(p, i)
#define NML_SPTR(i)
#define INTENTP(s, v)
#define DT_ISREAL(dt)
#define AD_MLPYR(p, i)
#define DTY(d)
#define ADD_NUMELM(dtyp)
#define SYMNAME(p)
#define NML_LINENO(i)
#define RUNTIMEG(sptr)
#define DT_DCMPLX
#define AD_LWAST(p, i)
#define DDTG(dt)
#define IS_TBP(func)
#define DTYG(dt)
#define ADD_DEFER(dtyp)
#define NML_NEXT(i)
#define AD_ASSUMSHP(p)
#define RFCNTI(s)
#define AD_DEFER(p)
#define AD_LWBD(p, i)
#define ST_ISVAR(s)
#define DT_ISWORD(dt)
#define AD_ADJARR(p)
#define IGNORE_TKR_ALL
#define LOCAL_SYMNAME(p)
#define ADD_NOBOUNDS(dtyp)
(Fortran) declarations needed to use dinitutil.c module.
Fortran semantic analyzer data definitions.
#define CONVAL2G(s)
#define CMEMLP(s, v)
#define FUNCLINEP(s, v)
#define FUNCLINEG(s)
#define GSAMEG(s)
#define CMEMLG(s)
#define ENDLINEP(s, v)
#define CONVAL2P(s, v)
__INT_T dtype
Definition: fortDt.h:301
int lineno
Definition: fpp.c:261
#define NULL
Definition: ftncharsup.c:22
#define TRUE
Definition: ftni64misc.c:14
#define FALSE
Definition: ftni64misc.c:15
int dim
Definition: func.c:204
int sptr
Definition: func.c:918
static struct @80 ss[SHIFTMAX]
int type
Definition: func.c:919
int def
Definition: induc.c:116
static struct @8 inited
static char ** arg
Definition: initpar.c:54
void import_init(void)
Initialize import of module symbols, etc.
Definition: interf.c:349
static int new_dtype(int)
Definition: interf.c:4115
Various definitions and prototypes for importing/exporting modules and IPA information.
int INT
Definition: legacy-ints.h:21
static char * uname
Definition: lockfile.c:55
static void init(int argc, char *argv[])
Initialize Fortran frontend at the beginning of compilation.
Definition: main.c:597
void begin_contains(void)
Definition: module.c:1174
void add_use_stmt()
Process a "USE module" statement. The module is specified in module_id.
Definition: module.c:235
void mod_end_subprogram(void)
Definition: module.c:2404
void close_module(void)
Definition: module.c:993
SPTR add_use_rename(SPTR local, SPTR global, LOGICAL is_operator)
Process a USE ONLY statement, optionally renaming 'global' as 'local'. The module is specified in 'mo...
Definition: module.c:267
LOGICAL get_seen_contains(void)
Definition: module.c:1114
void use_init(void)
Definition: module.c:213
void end_module(void)
Definition: module.c:1192
void open_module(SPTR use)
Begin processing a USE statement. use - sym ptr of module identifer in use statement Find or create a...
Definition: module.c:863
void apply_use_stmts(void)
Definition: module.c:352
SPTR begin_submodule(SPTR id, SPTR ancestor_mod, SPTR parent_submod, SPTR *parent)
Definition: module.c:1082
void mod_end_subprogram_two(void)
Definition: module.c:2425
int mod_add_subprogram(int subp)
Definition: module.c:2298
void mod_init()
Definition: module.c:2277
SPTR begin_module(SPTR id)
Definition: module.c:1056
void mod_implicit(int firstc, int lastc, int dtype)
Definition: module.c:1123
void add_submodule_use(void)
Definition: module.c:243
void init_use_stmts(void)
Definition: module.c:221
__BIGINT_T start
Definition: nmlread.c:50
__BIGINT_T end
Definition: nmlread.c:51
static int value(int ast)
Definition: outconv.c:1043
int std
Definition: outconv.c:4284
LOGICAL is_executable(int tkntyp)
Definition: parser.c:891
#define assert(cond, txt, val, sev)
Definition: pgerror.h:59
void interr(const char *txt, int val, enum error_severity sev)
Assert that cond is true, and emit an internal compiler error otherwise.
@ ERR_Severe
Definition: pgerror.h:27
@ ERR_Fatal
Definition: pgerror.h:28
@ ERR_Warning
Definition: pgerror.h:26
size_t strlen()
static void error(char *)
Definition: prodstr.c:193
static int count
Definition: pstride.c:42
__INT_T * ub
Definition: ptr.c:1275
int i
Definition: ptr.c:1277
__INT_T * lb
Definition: ptr.c:1275
float128_t val
Definition: qabs.c:13
unsigned int num[4]
Definition: qabs.c:14
DTYPE dt
Definition: regutil.cpp:850
int get_local_multiplier(int sdsc, int dim)
Definition: rte.c:654
void set_preserve_descriptor(int d)
Definition: rte.c:65
void get_static_descriptor(int sptr)
Definition: rte.c:413
int sym_get_sdescr(int sptr, int rank)
Definition: rte.c:171
int get_descriptor_sc(void)
Definition: rte.c:90
int get_extent(int sdsc, int dim)
Definition: rte.c:672
void set_descriptor_rank(int r)
Definition: rte.c:56
void get_all_descriptors(int sptr)
Definition: rte.c:435
void set_descriptor_sc(int sc)
Definition: rte.c:83
static fioerror * gbl
void fe_save_state(void)
Definition: scan.c:8709
int get_named_stmtyp(void)
Definition: scan.c:9459
void scan_options(void)
Definition: scan.c:7577
void scan_include(char *str)
Definition: scan.c:7395
data declarations for those items which are set by the scanner for use by the parser or semantic anal...
void scopestack_init()
Initialize the scope stack.
Definition: scopestack.c:31
void push_scope_level(int sptr, SCOPEKIND kind)
Push a slot on the scope stack.
Definition: scopestack.c:203
void par_pop_scope(void)
Definition: scopestack.c:411
void pop_scope_level(SCOPEKIND kind)
Definition: scopestack.c:250
static int construct_name
Definition: semant3.c:40
static void init_allocatable_typedef_components(int)
#define DA_STDCALL
Definition: semant.c:371
int cmp_len_parms(int ast1, int ast2)
Definition: semant.c:15335
static void do_iface(int)
Definition: semant.c:14288
static ACL * dup_acl(ACL *src, int sptr)
Definition: semant.c:16416
int queue_type_param(int sptr, int dtype, int offset, int flag)
Sets up type parameters used in parameterized derived types (PDTs)
Definition: semant.c:14647
static void end_subprogram_checks()
Definition: semant.c:766
static void _do_iface(int, int)
Definition: semant.c:14405
static int fixup_KIND_expr(int ast)
Definition: semant.c:13589
#define ET_OPTIONAL
Definition: semant.c:187
static void check_duplicate(bool checker, const char *op)
Emit a warning if a duplicate subproblem prefix is used.
Definition: semant.c:13946
int get_len_parm_by_number(int num, int dtype, int flag)
Definition: semant.c:15851
static int replace_sdsc_in_ast(int sdsc, int ast)
Definition: semant.c:15821
static void set_char_attributes(int, int *)
Definition: semant.c:12712
int no
Definition: semant.c:237
static LOGICAL entry_seen
Definition: semant.c:122
static void convert_intrinsics_to_idents(void)
Definition: semant.c:12988
int dimension
Definition: semant.c:227
static void search_kind(int ast, int *offset)
Definition: semant.c:14844
static void clear_iface(int i, SPTR iface)
Definition: semant.c:14391
#define DA_VALUE
Definition: semant.c:374
static void chk_initialization_with_kind_parm(int)
Definition: semant.c:15038
#define ET_MANAGED
Definition: semant.c:209
static LOGICAL wrong_name(SPTR endname)
Definition: semant.c:12885
LOGICAL put_kind_type_param(DTYPE dtype, int offset, int value, int expr, int flag)
Definition: semant.c:15922
#define DA_DECORATE
Definition: semant.c:376
static void chk_new_param_dt(int, int)
Definition: semant.c:16056
static LOGICAL is_pdt_dtype(DTYPE dtype)
Definition: semant.c:16450
#define DA_DLLIMPORT
Definition: semant.c:373
static void get_retval_derived_type()
Definition: semant.c:13824
#define DA_DLLEXPORT
Definition: semant.c:372
#define ET_SHARED
Definition: semant.c:201
static void record_func_result(int func_sptr, int func_result_sptr, LOGICAL in_ENTRY)
Definition: semant.c:16706
DTYPE create_parameterized_dt(DTYPE dtype, LOGICAL force)
Create a parameterized derived type based on dtype. If force is not set and dtype is already a PDT,...
Definition: semant.c:16298
static struct @155 entity_attr
#define ET_VOLATILE
Definition: semant.c:196
#define ET_INTENT
Definition: semant.c:185
int pass_arg
Definition: semant.c:232
#define ET_PASS
Definition: semant.c:197
int has_type_parameter(int dtype)
checks to see if derived type record, dtype, has any type parameters (kind or length type parameters)...
Definition: semant.c:16227
static void fix_iface0()
This routine sets the PASS field in a procedure pointer for semantic pass 0 prior to call to end_modu...
Definition: semant.c:14182
static void get_retval_LEN_value()
Definition: semant.c:13791
static int get_highest_param_offset(int)
Definition: semant.c:16274
static int create_var(int)
Definition: semant.c:13131
static LOGICAL ignore_common_decl(void)
Definition: semant.c:16466
static int cref
Definition: semant.c:151
static void do_iface_module(void)
Definition: semant.c:14300
static void defer_iface(int, int, int, int)
Definition: semant.c:14134
static void check_kind_type_param(int dtype)
Definition: semant.c:15904
#define ET_PROTECTED
Definition: semant.c:203
static void gen_unique_func_ast(int ast, SPTR sptr, SST *stkptr)
Definition: semant.c:12505
static void gen_dinit(int, SST *)
Definition: semant.c:12526
static int get_kind_parm(int, int)
Definition: semant.c:14902
void semant_init(int noparse)
Initialize semantic analyzer for new user subprogram unit.
Definition: semant.c:427
#define ET_ALLOCATABLE
Definition: semant.c:182
static int next_enum
Definition: semant.c:153
#define ET_STATIC
Definition: semant.c:193
static void set_len_attributes(SST *, int)
Definition: semant.c:12661
int internal_proc_has_ident(int ident, int proc)
Definition: semant.c:14042
bool in_intrinsic_decl(void)
Return the predicate: current entity has the INTRINSIC attribute.
Definition: semant.c:16481
static int restored
Definition: semant.c:775
static struct @154 lenspec[2]
#define _LEN_ZERO
Definition: semant.c:132
#define ET_CONTIGUOUS
Definition: semant.c:208
static void fix_iface(int)
Definition: semant.c:14206
static int host_present
Definition: semant.c:169
#define BYVALDEFAULT(ffunc)
Definition: semant.c:157
#define ET_LEN
Definition: semant.c:207
static void do_end_subprogram(SST *, RU_TYPE)
Definition: semant.c:12900
static LOGICAL in_entity_typdcl
Definition: semant.c:224
static int get_len_parm(int, int)
Definition: semant.c:15213
static LOGICAL craft_intrinsics
Definition: semant.c:119
static void fixup_param_vars(SST *, SST *)
Definition: semant.c:13266
static void copy_type_to_entry(int)
Definition: semant.c:12807
static struct dec_attr_t dec_attr
Definition: semant.c:393
#define ET_DIMENSION
Definition: semant.c:183
int propagated
Definition: semant.c:127
static void restore_host(INTERF *, LOGICAL)
Definition: semant.c:12863
#define ET_INTRINSIC
Definition: semant.c:186
#define ET_SAVE
Definition: semant.c:190
static int get_procedure_stype(int attr)
Determine procedure symbol type for a set of attributes.
Definition: semant.c:16514
void put_length_type_param(DTYPE dtype, int flag)
Definition: semant.c:15536
int get_unl_poly_sym(int mem_dtype)
Definition: semant.c:16118
#define DA_MAX
Definition: semant.c:378
int defer_pt_decl(int dtype, int flag)
Store dtypes of parameterized derived types in which a parameter was explicitly declared (as opposed ...
Definition: semant.c:15377
static int get_kind_parm_strict(int, int)
Definition: semant.c:14924
static void check_end_subprogram(RU_TYPE, int)
Definition: semant.c:12929
static void reloc_byvalue_parameters()
Definition: semant.c:662
static bool bindingNameRequiresOverloading(SPTR sptr)
Determine if a type bound procedure (tbp) binding name requires overloading.
Definition: semant.c:16764
static struct dec_attr_t bind_attr
Definition: semant.c:394
static void pop_subprogram(void)
Definition: semant.c:12604
static int create_func_entry_result(int)
Definition: semant.c:13107
#define _LEN_DEFER
Definition: semant.c:134
#define SYMI_SPTR(i)
Definition: semant.c:217
static int match_memname(int sptr, int list)
Definition: semant.c:16438
static void save_typedef_init(int, int)
Definition: semant.c:13433
#define ET_AUTOMATIC
Definition: semant.c:192
static void defer_put_kind_type_param(int, int, char *, int, int, int)
Definition: semant.c:15414
#define DA_NOMIXEDSLA
Definition: semant.c:377
static IFACE * iface_base
Definition: semant.c:109
DTYPE get_parameterized_dt(DTYPE dtype)
Duplicate dtype by creating a new derived type with a $pt suffix. For use with processing parameteriz...
Definition: semant.c:16335
static int eval_KIND_expr(int ast, int *val, int *dtyp)
Definition: semant.c:13682
#define ET_IMPL_MANAGED
Definition: semant.c:210
int chk_kind_parm_expr(int ast, int dtype, int flag, int strict_flag)
Definition: semant.c:15062
#define ET_POINTER
Definition: semant.c:189
int get_parm_by_number(int offset, int dtype)
search derived type for a type parameter in the same position as specified by offset.
Definition: semant.c:14985
#define DA_REFERENCE
Definition: semant.c:375
static int chk_intrinsic(int, LOGICAL, LOGICAL)
Definition: semant.c:13017
static void clear_ident_list()
Definition: semant.c:13915
#define _LEN_CONST
Definition: semant.c:130
static LOGICAL is_entry
Definition: semant.c:120
static void process_bind(int)
Definition: semant.c:13856
int all_len_parms_assumed(int dtype)
Return 0 if there's at least one length type parameter that is not assumed. Otherwise return 1.
Definition: semant.c:15883
const char * name
Definition: semant.c:236
static LOGICAL seen_options
Definition: semant.c:123
int chk_len_parm_expr(int ast, int dtype, int flag)
Definition: semant.c:15235
#define _LEN_ADJ
Definition: semant.c:133
int get_entity_access()
provide the current entity's access to other source files.
Definition: semant.c:16488
static void check_module_prefix()
MODULE prefix checking for subprograms C1547: cannot be inside a an abstract interface.
Definition: semant.c:13964
static void ctte(int entry, int sptr)
Definition: semant.c:12768
static int mscall
Definition: semant.c:150
#define DA_B(e)
Definition: semant.c:382
static INTERF host_state
Definition: semant.c:170
static int chk_asz_deferlen(int, int)
Definition: semant.c:15168
static IDENT_LIST * ident_base[HASHSIZE]
Definition: semant.c:113
#define ET_B(e)
Definition: semant.c:215
static LOGICAL dirty_ident_base
Definition: semant.c:114
static int end_of_host
Definition: semant.c:171
static void decr_ident_use(int ident, int proc)
Definition: semant.c:13972
static void save_host(INTERF *)
Definition: semant.c:12840
static struct @156 et[ET_MAX]
int getMscall()
provide mscall variable state to other source files.
Definition: semant.c:16495
void semant1(int rednum, SST *top)
Semantic actions - part 1.
Definition: semant.c:782
static void fix_proc_ptr_dummy_args()
Definition: semant.c:14256
#define DA_ALIAS
Definition: semant.c:369
static int chk_kind_parm(SST *)
Definition: semant.c:14867
#define ET_KIND
Definition: semant.c:206
static void get_retval_KIND_value()
Definition: semant.c:13735
#define ET_TARGET
Definition: semant.c:191
static LOGICAL is_exe_stmt
Definition: semant.c:121
#define ET_BIND
Definition: semant.c:194
const char * sem_pgphase_name()
Definition: semant.c:16791
int kind
Definition: semant.c:125
#define _LEN_ASSUM
Definition: semant.c:131
INT len
Definition: semant.c:126
#define ET_ASYNCHRONOUS
Definition: semant.c:204
#define SYMI_NEXT(i)
Definition: semant.c:218
#define ET_ACCESS
Definition: semant.c:181
static STSK * stsk
Definition: semant.c:116
#define ET_MAX
Definition: semant.c:211
char bounds[sizeof(sem.bounds)]
Definition: semant.c:230
static int decl_procedure_sym(int sptr, int proc_interf_sptr, int attr)
Declare a procedure symbol.
Definition: semant.c:16543
int exist
Definition: semant.c:226
static void defer_ident_list(int ident, int proc)
Definition: semant.c:13995
static struct @157 da[DA_MAX]
static LOGICAL seen_implicit
Definition: semant.c:117
static bool do_fixup_param_vars_for_derived_arrays(bool, SPTR, int)
To re-initialize an array of derived types when found the following conditions are satisfied:
Definition: semant.c:16827
#define ET_VALUE
Definition: semant.c:195
static int iface_avail
Definition: semant.c:110
static int chk_func_entry_result(int)
Definition: semant.c:13172
int getCref()
provide cref variable state to other source files.
Definition: semant.c:16502
char intent
Definition: semant.c:229
int get_kind_parm_by_name(char *np, int dtype)
search a derived type for a kind type parameter with a specified name.
Definition: semant.c:14955
#define ET_PARAMETER
Definition: semant.c:188
static int create_func_entry(int)
Definition: semant.c:13042
#define ET_PINNED
Definition: semant.c:200
static void clear_subp_prefix_settings(struct subp_prefix_t *)
Reset subprogram prefixes to zeroes.
Definition: semant.c:13955
char arrdim[sizeof(sem.arrdim)]
Definition: semant.c:231
char access
Definition: semant.c:228
void put_default_kind_type_param(int dtype, int flag, int flag2)
Definition: semant.c:15492
static struct subp_prefix_t subp_prefix
int get_len_set_parm_by_name(char *np, int dtype, int *val)
Definition: semant.c:15311
#define ET_DEVICE
Definition: semant.c:199
static int iface_size
Definition: semant.c:111
static void fixup_function_return_type(int, int)
Definition: semant.c:13574
int get_parm_by_name(char *np, int dtype)
search a derived type for a kind or length type parameter with a specified name.
Definition: semant.c:15013
static int has_type_parameter2(int dtype, int visit_flag)
Returns true if dtype is a derived type that has a type parameter or if it has a component that has a...
Definition: semant.c:16160
static LOGICAL seen_parameter
Definition: semant.c:118
#define ET_TEXTURE
Definition: semant.c:205
static void set_string_type_from_init(int, ACL *)
Definition: semant.c:13249
static int nomixedstrlen
Definition: semant.c:152
static int ident_host_sub
Definition: semant.c:89
#define ERR310(s1, s2)
Definition: semant.c:173
static void symatterr(int, int, const char *)
Definition: semant.c:13565
int has_length_type_parameter_use(int dtype)
Definition: semant.c:16254
static int setup_procedure_sym(int sptr, int proc_interf_sptr, int attr, char access)
Process procedure declaration.
Definition: semant.c:16608
int is_parameter_context()
allow other source files to check whether we're processing a parameter construct.
Definition: semant.c:16460
static void get_param_alias_const(SST *, int, int)
Definition: semant.c:13207
#define ET_NOPASS
Definition: semant.c:198
static void replace_sdsc_in_bounds(int sdsc, ADSC *ad, int i)
Definition: semant.c:15796
#define ET_CONSTANT
Definition: semant.c:202
#define ET_EXTERNAL
Definition: semant.c:184
void build_typedef_init_tree(int sptr, int dtype)
Definition: semant.c:13468
#define DA_C
Definition: semant.c:370
static int has_kind_parm_expr(int, int, int)
Definition: semant.c:15116
static int get_vtoff(int, DTYPE)
Definition: semant.c:16096
static void set_aclen(SST *, int, int)
Definition: semant.c:12727
static const char * name_of_rutype(RU_TYPE)
Definition: semant.c:12967
static struct cl_tag cl[CL_MAXV]
#define SST_GDTYPEG(p)
Definition: semstk.h:133
#define SST_ENDG(p)
Definition: semstk.h:153
#define SST_SUBSCRIPTP(p, v)
Definition: semstk.h:188
#define SST_NMLBEGP(p, v)
Definition: semstk.h:191
#define SST_TMPG(p)
Definition: semstk.h:119
#define SST_VLENDP(p, v)
Definition: semstk.h:201
#define SST_IDG(p)
Definition: semstk.h:97
#define SST_OFFSETG(p)
Definition: semstk.h:149
#define SST_CVALG(p)
Definition: semstk.h:132
#define SST_RNG2P(p, v)
Definition: semstk.h:203
#define SST_E1P(p, v)
Definition: semstk.h:204
int mkvarref(SST *, ITEM *)
Make a var ref of the form: <var primary> ( [<ssa list>] )
Definition: semutil.c:2063
#define SST_CLENDG(p)
Definition: semstk.h:156
#define SST_GTYP(p, v)
Definition: semstk.h:176
void constant_lvalue(SST *)
If stkptr is an LVALUE that has a constant value, replace it with the constant value.
Definition: semutil.c:70
#define SST_CLBEGP(p, v)
Definition: semstk.h:196
#define SST_ERRSYMP(p, v)
Definition: semstk.h:179
#define SST_LSYMG(p)
Definition: semstk.h:136
#define SST_SUBSTRINGG(p)
Definition: semstk.h:148
#define SST_ACLP(p, v)
Definition: semstk.h:187
#define SST_SHAPEP(p, v)
Definition: semstk.h:180
INT chkcon(SST *, int, LOGICAL)
Check that the indicated semantic stack entry is a constant of the specified type and convert constan...
Definition: semutil.c:98
#define SST_LSYMP(p, v)
Definition: semstk.h:177
#define RHS(i)
Definition: semstk.h:20
#define SST_E3P(p, v)
Definition: semstk.h:206
#define LHS
Definition: semstk.h:19
#define SST_RNG1G(p)
Definition: semstk.h:161
#define SST_NMLENDP(p, v)
Definition: semstk.h:192
#define SST_FLAGP(p, v)
Definition: semstk.h:101
#define SST_E3G(p)
Definition: semstk.h:165
#define SST_GDTYPEP(p, v)
Definition: semstk.h:174
#define SST_VLBEGP(p, v)
Definition: semstk.h:200
ISZ_T chkcon_to_isz(SST *, LOGICAL)
Check that the indicated semantic stack entry is a constant of any integer type.
Definition: semutil.c:165
#define SST_COLUMNG(p)
Definition: semstk.h:125
#define SST_SUBSTRINGP(p, v)
Definition: semstk.h:189
#define SST_CLENDP(p, v)
Definition: semstk.h:197
#define SST_DTYPEP(p, v)
Definition: semstk.h:175
#define SST_GTYG(p)
Definition: semstk.h:135
#define SST_BEGG(p)
Definition: semstk.h:152
#define SST_CVALP(p, v)
Definition: semstk.h:173
VAR * dinit_varref(SST *)
Create an initialization node for a variable reference in a data statement.
Definition: semutil2.c:7709
#define SST_CLBEGG(p)
Definition: semstk.h:155
void dinit_struct_param(SPTR, ACL *, DTYPE)
Definition: semutil2.c:7590
#define SST_E2P(p, v)
Definition: semstk.h:205
#define SST_ASTP(p, v)
Definition: semstk.h:111
#define SST_BEGP(p, v)
Definition: semstk.h:193
void mkident(SST *)
Definition: semutil.c:1084
void construct_acl_for_sst(SST *, DTYPE)
Definition: semutil2.c:5045
#define SST_NMLBEGG(p)
Definition: semstk.h:150
#define SST_OPTYPEP(p, v)
Definition: semstk.h:171
#define SST_NMLENDG(p)
Definition: semstk.h:151
void ch_substring(SST *, SST *, SST *)
Substring of a character constant.
Definition: semutil.c:3189
INT chk_scalartyp(SST *, int, LOGICAL)
Same as chktyp() with the restriction that the expression must be a scalar (i.e., not an array/vector...
Definition: semutil.c:227
#define SST_ENDP(p, v)
Definition: semstk.h:194
#define SST_VLBEGG(p)
Definition: semstk.h:159
#define SST_ALIASP(p, v)
Definition: semstk.h:107
#define SST_SUBSCRIPTG(p)
Definition: semstk.h:147
#define SST_ACLG(p)
Definition: semstk.h:146
#define SST_OFFSETP(p, v)
Definition: semstk.h:190
#define SST_FIRSTP(p, v)
Definition: semstk.h:183
#define SST_E1G(p)
Definition: semstk.h:163
#define SST_FIRSTG(p)
Definition: semstk.h:142
#define SST_PARENP(p, v)
Definition: semstk.h:104
INT chk_arr_extent(SST *, const char *)
Restrict the expression to be suitable for an array extent.
Definition: semutil.c:259
int mklvalue(SST *, int)
Check for legal variable to be assigned to.
Definition: semutil.c:1442
#define SST_TMPP(p, v)
Definition: semstk.h:120
#define SST_OPTYPEG(p)
Definition: semstk.h:130
#define SST_SYMG(p)
Definition: semstk.h:131
#define SST_SYMP(p, v)
Definition: semstk.h:172
#define SST_VLENDG(p)
Definition: semstk.h:160
#define SST_FLAGG(p)
Definition: semstk.h:100
INT chktyp(SST *, int, LOGICAL)
Convert expression pointed to by stkptr from its current data type to data type dtype.
Definition: semutil.c:199
int mkexpr(SST *)
Definition: semutil.c:1093
#define SST_ASTG(p)
Definition: semstk.h:110
#define SST_IDP(p, v)
Definition: semstk.h:98
#define SST_LINENOG(p)
Definition: semstk.h:122
#define SST_DTYPEG(p)
Definition: semstk.h:134
#define SST_RNG2G(p)
Definition: semstk.h:162
#define SST_E2G(p)
Definition: semstk.h:164
int itemp
Definition: semutil.c:6020
gbldefs.h - syminit/symutil utility definitions
static double first
Definition: stat_linux.c:101
int i0
Definition: ast.in.h:287
int zero
Definition: ast.in.h:319
int i1
Definition: ast.in.h:288
int one
Definition: ast.in.h:320
int dtype
Definition: ast.in.h:321
struct ASTB::@210 bnd
const char * atypes[AST_MAX+1]
Definition: ast.in.h:282
Deferred procedure interface.
LOGICAL seen_parameter
LOGICAL is_hpf
Definition: scan.h:22
INT labno
Definition: scan.h:20
char * directive
Definition: scan.h:26
int currlab
Definition: scan.h:19
int stmtyp
Definition: scan.h:18
struct SCN::@153 id
char * name
Definition: scan.h:34
PHASE_TYPE pgphase
SCOPESTACK * scope_stack
LOGICAL mod_dllexport
struct SEM::@181 stats
ITEM * len_candidate
LOGICAL ieee_features
DTYPE doconcurrent_dtype
LOGICAL contiguous
LOGICAL seen_end_module
STD_RECORD * elp_stack
LOGICAL dinit_data
IFACE * iface_base
LOGICAL dinit_error
struct SEM::@179 mpaccatomic
LOGICAL temps_reset
LOGICAL ignore_default_none
ITEM * alloc_mem_initialize
INTERF * interf_base
LOGICAL atomic[3]
ITEM * kind_candidate
LOGICAL seen_import
struct _sem_arrdim arrdim
struct SEM::@177 master
ITEM * auto_finalize
ITEM * type_initialize
STD_RANGE * ac_std_range
ITEM * p_dealloc_delete
LOGICAL expect_dist_do
LOGICAL expect_simd_do
int * non_private_base
struct SEM::@178 critical
int deferred_kind_len_lineno
LOGICAL ignore_stmt
SPTR doconcurrent_symavl
struct _sem_bounds bounds[MAXDIMS]
SPTR hashtb[HASHSIZE+1]
struct STB::@203 user
OVCLASS ovclass[ST_MAX+1]
int none_implicit
Definition: symutl.h:120
struct VAR::@256::@257 dostart
struct VAR::@256::@259 varref
union VAR::@256 u
struct VAR::@256::@258 doend
struct VAR * next
struct _accl * next
struct _acl * next
struct _acl * subc
union _acl::@175 u1
struct _seql * next
Definition: scan.c:7509
int exist
Definition: semant.c:389
int altname
Definition: semant.c:390
struct ident_list * next
IDENT_PROC_LIST * proc_list
struct ident_proc_list * next
Definition: semstk.h:32
ACL * acl
Definition: semstk.h:56
struct sst::@188::@190 cnval
union sst::@188 value
Subprogram prefix struct defintions for RECURESIVE, PURE, IMPURE, ELEMENTAL, and MODULE.
Definition: semant.c:139
bool recursive
Definition: semant.c:140
bool elemental
Definition: semant.c:143
bool impure
Definition: semant.c:142
bool module
Definition: semant.c:144
bool pure
Definition: semant.c:141
struct visit_list * next
Definition: dtypeutl.c:263
struct sst * stkp
struct xyyz * next
union xyyz::@158 t
SPTR instantiate_interface(SPTR iface)
Instantiate a copy of a separate module subprogram's declared interface as part of the MODULE PROCEDU...
Definition: symtab.c:2884
int add_symitem(int sptr, int nxt)
...
Definition: symtab.c:3181
int getccsym(int letter, int n, SYMTYPE stype)
Definition: symtab.c:1726
void proc_arginfo(int sptr, int *paramct, int *dpdsc, int *iface)
Definition: symtab.c:2367
void newimplicitnone(void)
Definition: symtab.c:839
void change_predefineds(int stype, LOGICAL remove)
Definition: symtab.c:3195
void init_implicit(void)
Definition: symtab.c:321
SPTR find_explicit_interface(SPTR s)
Definition: symtab.c:2861
void copy_sym_flags(SPTR dest, SPTR src)
Copy flags from one symbol to another symbol.
Definition: symtab.c:2791
void reinit_sym(int sptr)
Definition: symtab.c:3015
int getccsym_sc(int letter, int n, int stype, int sc)
Definition: symtab.c:1812
INT get_int_cval(int con)
Definition: symtab.c:674
int getsym(const char *name, int olength)
Enter symbol with indicated name into symbol table, initialize the new entry.
Definition: symtab.c:460
LOGICAL is_procedure_ptr(int sptr)
Definition: symtab.c:2350
void save_implicit(LOGICAL reset)
Definition: symtab.c:357
void newimplicit(int firstc, int lastc, int dtype)
Change the current settings for implicit variable types and character lengths.
Definition: symtab.c:810
int getsymbol(const char *name)
...
Definition: symtab.c:445
void dup_sym(int new, SYM *content)
Definition: symtab.c:2820
int insert_dup_sym(int sptr)
Definition: symtab.c:2835
bool cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag)
Same as cmp_interfaces() except we also compare the characteristics as defined in "12....
Definition: symtab.c:2655
int getsymf(const char *fmt,...)
Definition: symtab.c:500
ISZ_T get_isz_cval(int con)
...
Definition: symtab.c:650
int resolve_sym_aliases(int sptr)
Definition: symtab.c:2341
void pop_sym(int sptr)
remove a symbol from its hash list
Definition: symtab.c:2101
bool cmp_interfaces(int sym1, int sym2, int flag)
Compares two symbols by returning true if they both have equivalent interfaces. Otherwise,...
Definition: symtab.c:2449
void restore_implicit(void)
Definition: symtab.c:378
int getlab(void)
...
Definition: symtab.c:2048
int getstring(const char *value, int length)
Enter character constant into symbol table and return pointer to it.
Definition: symtab.c:724
SPTR getcon(INT *value, DTYPE dtype)
Enter constant of given dtype and value into the symbol table and return pointer to it.
Definition: symtab.c:524
void setimplicit(int sptr)
...
Definition: symtab.c:853
int insert_sym(int first)
Definition: symtab.c:1985
int sym_get_scalar(const char *basename, const char *purpose, int dtype)
Definition: symutl.c:129
int get_next_hash_link(int sptr, int task)
utility function for visiting symbols of a specified name.
Definition: symutl.c:3564
int findByNameStypeScope(char *symname, int stype, int scope)
utility function for finding a symbol in the symbol table that has a specified name.
Definition: symutl.c:3619
int first_hash(int sptr)
Definition: symutl.c:3509
int find_dummy_position(int proc_sptr, int arg_sptr)
Definition: symutl.c:3784
SPTR get_member_descriptor(int sptr)
Definition: symutl.c:3717
LOGICAL is_tbp(int sptr)
Definition: symutl.c:3833
SYMUTL symutl
Definition: symutl.c:33
bool is_impure(int sptr)
Definition: symutl.c:3661
int get_next_sym(const char *basename, const char *purpose)
Definition: symutl.c:45
Symbol utilities
void errwarn(error_code_t ecode)
Issue a warning for gbl.lineno.
void errlabel(error_code_t ecode, enum error_severity sev, int eline, char *nm, const char *op2)
Massage label name if necesseary.
void errsev(error_code_t ecode)
Issue a severe error message for gbl.lineno.
FTN global variables and flags.
#define FLANG_FALLTHROUGH
FLANG_FALLTHROUGH - Mark fallthrough cases in switch statements.
Definition: universal.h:35
#define pdtype
Definition: upperl.c:458
int j
Definition: upperl.c:512